frmprint.frm

朋友给的

        dmPelsHeight As Long
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
End Type

Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type


Private Declare Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, ByVal lpOutput As String, lpDevMode As DEVMODE) As Long
Private Declare Function DeviceCapabilities1 Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Integer, lpDevMode As DEVMODE) As Long

Private Type CaptionField
            Caption As String
            MergeRight  As Boolean
            MergeBottom As Boolean
        End Type
'私有属性
Private lngOldPaperSize As Long
Private lngOldOrientation As Long
Private lngPageCount As Long '保留,无用
Private lngTitleHeight As Long '报表标题高度
Private lngCaptionHeight As Long '报表首行高度
Private lngFooterHeight As Long '报表末行高度
Private lngColumnHeaderHeight As Long '列头高度
Private lngLeftMargin As Long '左边距
Private lngRightMargin As Long '右边距
Private lngTopMargin As Long '顶边距
Private lngBottomMargin As Long '底边距
Private lngRealWidth As Long '可供打印内容的实际纸张宽度
Private lngRealHeight As Long '可供打印内容的实际纸张高度
Private sngZoom As Single '暂保留,预览缩放比例
Private sngFontSize As Single '打印字体大小
Private lngPaperWidth As Long '纸张宽度
Private lngPaperHeight As Long '纸张高度
Private lngFirstRowPerPage() As Long '每页的第一行
Private lngFirstColPerPage() As Long '每页的第一列
Private lngStartPerCol() As Long '每列的起始位置
Private lngStartPerRow() As Long '每行的起始位置,不包括固定行
Private lngPageCountH As Long '横向页数
Private lngPageCountV As Long '纵向页数
Private lngTotalPages As Long '总页数
Private msgPrintGrid As MSFlexGrid '保留
Private rstPrintRecordset As ADODB.Recordset '保留
Private strReportTitle As String '报表标题
Private strReportCaption As String '报表首行
Private strReportFooter As String '报表末行
Private strPageCodeStyle As Long '保留,页码格式

Private strReportName As String
Private bLoad As Boolean
Private Function SetPage() As Long
Dim i As Long, j As Long
On Error GoTo Err_Handle
    '初始化打印参数
    sngFontSize = cmbFontSize.ItemData(cmbFontSize.ListIndex) / 10
    '页边距
    lngTopMargin = Val(txtMargin(0).Text) * PIXELS_PER_CM
    lngBottomMargin = Val(txtMargin(1).Text) * PIXELS_PER_CM
    lngLeftMargin = Val(txtMargin(2).Text) * PIXELS_PER_CM
    lngRightMargin = Val(txtMargin(3).Text) * PIXELS_PER_CM

    '标题,首行,末行
    strReportTitle = txtReportTitle.Text
    strReportCaption = txtReportCaption.Text
    strReportFooter = txtReportFooter.Text
    
    '页面宽度,页面高度
    lngTitleHeight = IIf(strReportTitle = "", 0, 20 * 10 * 2 * 2.5)
    lngCaptionHeight = IIf(strReportCaption = "", 0, sngFontSize * 10 * 2 * 1.5)
    lngFooterHeight = IIf(strReportFooter = "", 0, sngFontSize * 10 * 2 * 1.5)
    
    lngPaperWidth = txtWidth.Text * PIXELS_PER_CM
    lngPaperHeight = txtHeight.Text * PIXELS_PER_CM
    
    
Dim lngCurrentWidth As Long
Dim lngCurrentHeight As Long
Dim lngCurrentPage As Long
    
    
    lngRealWidth = lngPaperWidth - lngLeftMargin - lngRightMargin
'    On Error Resume Next
    msgContents.TopRow = msgContents.FixedRows
'    On Error GoTo 0
    lngColumnHeaderHeight = msgContents.RowPos(msgContents.FixedRows)
    lngRealHeight = lngPaperHeight - lngTopMargin - lngBottomMargin - lngTitleHeight - lngCaptionHeight - lngFooterHeight - lngColumnHeaderHeight
    
    
    If lngRealWidth < 0 Or lngRealHeight < 0 Then
        MsgBox "请注意,页面宽度或高度设置过大,请重新设置!"
        SetPage = 1
        Exit Function
    End If
    
    
    Dim lngCurrent As Long
    
    With Me.msgContents
        ReDim lngStartPerCol(.Cols - 1)
        ReDim lngStartPerRow(.Rows - 1)
        '计算横向页面数
        ReDim lngFirstColPerPage(0) As Long
        lngCurrentWidth = 0 '.ColWidth(0)
        lngFirstColPerPage(0) = 0
        lngCurrentPage = 0
        lngPageCountH = 1
        .LeftCol = 0
        lngCurrent = 0
        For i = 0 To .Cols - 1
            
            lngCurrentWidth = lngCurrentWidth + .ColWidth(i)
            
            If lngCurrentWidth > lngRealWidth Then
                lngCurrentPage = lngCurrentPage + 1
                ReDim Preserve lngFirstColPerPage(lngCurrentPage)
                lngCurrent = i
                lngFirstColPerPage(lngCurrentPage) = i
                lngPageCountH = lngPageCountH + 1
                lngCurrentWidth = .ColWidth(i)
            End If
            lngStartPerCol(i) = .ColPos(i) - .ColPos(lngCurrent)
        Next i

        '计算纵向页面数
        ReDim lngFirstRowPerPage(0) As Long
        lngCurrentHeight = 0 ' .RowHeight(.FixedRows)
        lngFirstRowPerPage(0) = .FixedRows
        lngCurrentPage = 0
        lngPageCountV = 1
        .TopRow = .FixedRows
        lngCurrent = .FixedRows
        For i = .FixedRows To .Rows - 1
            lngCurrentHeight = lngCurrentHeight + .RowHeight(i)
            
            If lngCurrentHeight > lngRealHeight Then
                lngCurrentPage = lngCurrentPage + 1
                ReDim Preserve lngFirstRowPerPage(lngCurrentPage)
                lngFirstRowPerPage(lngCurrentPage) = i
                lngCurrent = i
                lngPageCountV = lngPageCountV + 1
                lngCurrentHeight = .RowHeight(i)
            End If
            lngStartPerRow(i) = .RowPos(i) - .RowPos(lngCurrent)
        Next i
        '计算总页数
        lngTotalPages = lngPageCountV * lngPageCountH
        
    End With
    
    Exit Function
Err_Handle:
    MsgBox "发生下列错误" & vbCrLf & "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbOKOnly, "打印错误"

End Function

Private Function PrintReportTitle(obj As Object) As Long
    Dim lngWidth As Long
    On Error GoTo Err_Handle
    PrintReportTitle = 0
    If strReportTitle = "" Then
        Exit Function
    End If
    With obj
        .Font.name = "楷体_GB2312"
        .Font.Size = 20
        lngWidth = obj.TextWidth(strReportTitle)
        If lngWidth <= lngRealWidth Then
            .CurrentX = (lngRealWidth - lngWidth) / 2 + lngLeftMargin
            .CurrentY = lngTopMargin
            obj.Print strReportTitle
        End If
        .Font.name = "宋体"
        .Font.Size = sngFontSize
    End With
    Exit Function
Err_Handle:
    MsgBox "发生下列错误" & vbCrLf & "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbOKOnly, "打印错误"
End Function

Private Function PrintReportCaption(obj As Object) As Long
    Dim lngWidth As Long
On Error GoTo Err_Handle
    PrintReportCaption = 0
    If strReportCaption = "" Then
        Exit Function
    End If
    With obj

        lngWidth = obj.TextWidth(strReportCaption)
        If lngWidth <= lngRealWidth Then
            If chkAlignLeft.Value = vbChecked Then
                .CurrentX = lngLeftMargin
            Else
                .CurrentX = (lngRealWidth - lngWidth) + lngLeftMargin
            End If
            .CurrentY = lngTopMargin + lngTitleHeight
            obj.Print strReportCaption
        End If
    End With
    Exit Function
Err_Handle:
    MsgBox "发生下列错误" & vbCrLf & "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbOKOnly, "打印错误"
End Function

Private Function PrintColumnHeader(obj As Object, ByVal ColStart As Long, ByVal ColEnd As Long) As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lngIsPrint() As Long
    Dim lngFixedRows As Long
    Dim lngCC As Long
    Dim lngCR As Long
    Dim lngCR1 As Long
    Dim lngCC1 As Long
    Dim lngCX As Long
    Dim lngCY As Long
    Dim lngStartH As Long
    Dim lngStartV As Long
    Dim lngAdd As Long
    Dim strFieldName() As String
    Dim lngRows As Long
    Dim lngSearchStart As Long
    Dim lngResult As Long
On Error GoTo Err_Handle
    PrintColumnHeader = 0
    lngFixedRows = msgContents.FixedRows
    If lngFixedRows = 0 Then
        Exit Function
    End If
    ReDim lngIsPrint(lngFixedRows - 1, ColStart To ColEnd) As Long
    
    lngStartH = lngLeftMargin
    lngStartV = lngTopMargin + lngTitleHeight + lngCaptionHeight
    With obj
        For i = 0 To lngFixedRows - 1
            For j = ColStart To ColEnd
                If msgContents.ColWidth(j) > 0 Then
                    If lngIsPrint(i, j) = 0 Then
                        lngCC = j
                        lngCC1 = j
                        While lngCC1 < ColEnd
                            lngCC1 = lngCC1 + 1
                            If msgContents.TextMatrix(i, j) = msgContents.TextMatrix(i, lngCC + 1) Then
                                lngCC = lngCC + 1
                            End If
                        Wend
                        If lngCC = j Then '横向没有合并
                            lngCR = i
                            lngCR1 = i
                            While lngCR1 < lngFixedRows - 1
                                lngCR1 = lngCR1 + 1
                                If msgContents.TextMatrix(i, j) = msgContents.TextMatrix(lngCR + 1, j) Then
                                    lngCR = lngCR + 1
                                End If
                            Wend
                            For k = i To lngCR
                                lngIsPrint(k, j) = 1
                            Next k
                            
                            
                            lngRows = 1
                            ReDim strFieldName(0)
                            lngSearchStart = 1
                            lngResult = InStr(lngSearchStart, msgContents.TextMatrix(i, j), S_RETURN)

                            While lngResult > 0
                                ReDim Preserve strFieldName(lngRows)
                                If lngRows = 1 Then
                                    strFieldName(lngRows - 1) = Mid(msgContents.TextMatrix(i, j), lngSearchStart, lngResult - lngSearchStart)
                                Else
                                    strFieldName(lngRows - 1) = Mid(msgContents.TextMatrix(i, j), lngSearchStart, lngResult - lngSearchStart - 1)
                                End If
                                lngSearchStart = lngResult
                                lngResult = InStr(lngResult + 1, msgContents.TextMatrix(i, j), S_RETURN)
                                lngRows = lngRows + 1
                            Wend
                            If lngRows = 1 Then
                                strFieldName(lngRows - 1) = Mid(msgContents.TextMatrix(i, j), lngSearchStart)
                            Else
                                strFieldName(lngRows - 1) = Mid(msgContents.TextMatrix(i, j), lngSearchStart + 1)
                            End If
                            
                            Dim lngH As Long
                            lngH = msgContents.RowPos(lngCR) - msgContents.RowPos(i) + msgContents.RowHeight(lngCR) - lngRows * obj.TextHeight(" ")
                            lngH = lngH / (lngRows + 1)
                            For k = 0 To lngRows - 1
                                lngCX = lngLeftMargin + (lngStartPerCol(j) + lngStartPerCol(lngCC) + msgContents.ColWidth(lngCC) - sngFontSize * 10 * RealLength(strFieldName(k))) / 2 - LINE_ADJUST
                                .CurrentX = lngCX 'lngLeftMargin + lngStartPerCol(j)
                                lngCY = lngTopMargin + lngTitleHeight + lngCaptionHeight + msgContents.RowPos(i) _
                                + lngH * (k + 1) + obj.TextHeight(" ") * k - LINE_ADJUST
                                .CurrentY = lngCY
                                obj.Print strFieldName(k) 'msgContents.TextMatrix(i, j)
                            Next k
                            
                            obj.Line (lngStartH + lngStartPerCol(j) - LINE_ADJUST, lngStartV + msgContents.RowPos(i) - LINE_ADJUST)-(lngStartH + lngStartPerCol(lngCC) + msgContents.ColWidth(lngCC) - LINE_ADJUST, lngStartV + msgContents.RowPos(i) - LINE_ADJUST)
                            obj.Line (lngStartH + lngStartPerCol(j) - LINE_ADJUST, lngStartV + msgContents.RowPos(i) - LINE_ADJUST)-(lngStartH + lngStartPerCol(j) - LINE_ADJUST, lngStartV + msgContents.RowPos(lngCR) + msgContents.RowHeight(lngCR) - LINE_ADJUST)
                            
                        Else '横向有合并
                            For k = j To lngCC
                                lngIsPrint(i, k) = 1
                            Next k
                            lngCX = lngLeftMargin + (lngStartPerCol(j) + lngStartPerCol(lngCC) + msgContents.ColWidth(lngCC) - sngFontSize * 10 * RealLength(msgContents.TextMatrix(i, j))) / 2 - LINE_ADJUST
                            .CurrentX = lngCX
                            .CurrentY = lngTopMargin + lngTitleHeight + lngCaptionHeight + msgContents.RowPos(i)
                            obj.Print msgContents.TextMatrix(i, j)
                            obj.Line (lngStartH + lngStartPerCol(j) - LINE_ADJUST, lngStartV + msgContents.RowPos(i) - LINE_ADJUST)-(lngStartH + lngStartPerCol(lngCC) + msgContents.ColWidth(lngCC) - LINE_ADJUST, lngStartV + msgContents.RowPos(i) - LINE_ADJUST)
                            obj.Line (lngStartH + lngStartPerCol(j) - LINE_ADJUST, lngStartV + msgContents.RowPos(i) - LINE_ADJUST)-(lngStartH + lngStartPerCol(j) - LINE_ADJUST, lngStartV + msgContents.RowPos(lngCR) + msgContents.RowHeight(lngCR) - LINE_ADJUST)
                            
                        End If
                    End If
                    
                End If
            Next j
        Next i
        obj.Line (lngStartH + lngStartPerCol(ColEnd) + msgContents.ColWidth(ColEnd) - LINE_ADJUST, lngStartV + msgContents.RowPos(0) - LINE_ADJUST)-(lngStartH + lngStartPerCol(ColEnd) + msgContents.ColWidth(ColEnd) + LINE_ADJUST, lngStartV + msgContents.RowPos(0) - LINE_ADJUST)
        obj.Line (lngStartH + lngStartPerCol(ColEnd) + msgContents.ColWidth(ColEnd) + LINE_ADJUST, lngStartV + msgContents.RowPos(0) - LINE_ADJUST)-(lngStartH + msgContents.ColWidth(ColEnd) + lngStartPerCol(ColEnd) + LINE_ADJUST, lngStartV + msgContents.RowPos(msgContents.FixedRows - 1) + msgContents.RowHeight(msgContents.FixedRows - 1) - LINE_ADJUST)
    End With
    Exit Function
Err_Handle:
    MsgBox "发生下列错误" & vbCrLf & "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description, vbOKOnly, "打印错误"
End Function

Private Function PrintReportFooter(obj As Object) As Long
    
    Dim lngWidth As Long
On Error GoTo Err_Handle
    PrintReportFooter = 0