frmmodcommonprint.frm

通用书店管理系统

    
    '如果不显示则直接退出
    If strPageOfFormat = "不显示" Then Exit Sub
    
    '处理显示格式
    strPageValue = Replace(strPageOfFormat, "(页码)", curPage)
    strPageValue = Replace(strPageValue, "(页数)", TotalPages)
    
    Dim sumColumns As Double, i%
    If TypeName(arrColWidth) = "Variant" Then
        sumColumns = 0
    Else
        For i = 0 To UBound(arrColWidth)
            sumColumns = sumColumns + Val(arrColWidth(i))
        Next i
    End If
           
    Select Case Trim(strPageOfPosType)
    Case "右上角"
        vp.CurrentY = vp.MarginHeader - vp.TextHeight("好") * 1 - 50
        vp.CurrentX = vp.PageWidth - vp.MarginRight - vp.TextWidth(strPageValue)
    Case "右下角"
        vp.CurrentY = vp.PageHeight - vp.MarginFooter + vp.TextHeight("好") * 1
        vp.CurrentX = vp.PageWidth - vp.MarginRight - vp.TextWidth(strPageValue)
    Case "表格右上方"
        If curPage = 1 Then
            vp.CurrentY = vp.MarginHeader + Title_Height + SayingAboveTable_Height - vp.TextHeight("好") * 1 - 50
        Else
            vp.CurrentY = vp.MarginTop - TopHeader_Height - vp.TextHeight("好") * 1 - 50
        End If
        vp.CurrentX = vp.MarginLeft + sumColumns - vp.TextWidth(strPageValue) - 200
    Case "表格右下方"
        If curPage = 1 Then
            vp.CurrentY = vp.PageHeight - vp.MarginFooter - SayingBelowTable_Height - Sign_Height + 50
        Else
            vp.CurrentY = vp.PageHeight - vp.MarginBottom + SubTotal_Height + 50
        End If
        vp.CurrentX = vp.MarginLeft + sumColumns - vp.TextWidth(strPageValue) - 200
    Case "自定义"
        arrPageOfPosXY = Split(strPageOfPosXY, ",")
        If UBound(arrPageOfPosXY) = 1 Then
            vp.CurrentX = Val(arrPageOfPosXY(0))
            vp.CurrentY = Val(arrPageOfPosXY(1))
        End If
    End Select
    
    vp.FontSize = 10
    
    If TableLabelVisable And (Not TableTextVisable) Then              '控制交给表格标签是否显示
        vp.Text = Replace(Replace(strPageOfFormat, "(页码)", Left("          ", Len(CStr(curPage)))), "(页数)", Left("          ", Len(CStr(TotalPages))))
    ElseIf (Not TableLabelVisable) And TableTextVisable Then
        strPageValue = Replace(Replace(strPageOfFormat, "(页码)", Chr(0) & "(页码)" & Chr(0)), "(页数)", Chr(0) & "(页数)" & Chr(0))
        Dim arrTemp() As String
        Dim strTemp$
        arrTemp = Split(strPageValue, Chr(0))
        strTemp = Left("                    ", Len(StrConv(arrTemp(0), vbUnicode)))
        strTemp = strTemp & arrTemp(1)
        strTemp = strTemp & Left("                    ", Len(StrConv(arrTemp(2), vbUnicode)))
        strTemp = strTemp & arrTemp(3)
        strTemp = strTemp & Left("                    ", Len(StrConv(arrTemp(4), vbUnicode)))
        vp.Text = Replace(Replace(strTemp, "(页码)", curPage), "(页数)", TotalPages)
    Else
        vp.Text = strPageValue
    End If
        
End Sub

Private Sub setPrintSetup()
    
    Dim p%
    
    frm.strDBMainTable = strDBMainTable
    frm.strDBDetailTable = strDBDetailTable
    
    Set frm.PrintInfo = PrintInfo
    frm.strPrintInfoName = Me.strPrintInfoName
    Set frm.frmParent = Me
    
    frm.PrintMarginLeft = vp.MarginLeft
    frm.PrintMarginRight = vp.MarginRight
    frm.PrintMarginHeader = vp.MarginHeader
    frm.PrintMarginFooter = vp.MarginFooter
    frm.PrintOrientation = vp.Orientation
    
    frm.PrintPaperSize = vp.PaperSize
    frm.PrintPaperHeight = vp.PaperHeight
    frm.PrintPaperWidth = vp.PaperWidth
    
    frm.intPrintModel = Me.intPrintModel
    
    frm.Show vbModal
    
    If Not frm.blnOK Then Exit Sub
    
    '全部打印
    If frm.optPageRange(0).Value Then
        ReDim strPageRange(0)
        strPageRange(0) = 1 & "-" & vp.PageCount
    End If
    '打印当前页
    If frm.optPageRange(1).Value Then
        ReDim strPageRange(0)
        strPageRange(0) = vp.PreviewPage & "-" & vp.PreviewPage
    End If
    '选择打印
    If frm.optPageRange(2).Value Then
        strPageRange = Split(Trim(frm.txtPageRange), ",")
        
        For p = 0 To UBound(strPageRange)
            If InStr(1, strPageRange(p), "-") = 0 Then _
                strPageRange(p) = strPageRange(p) & "-" & strPageRange(p)
        Next p
    End If
    '打印奇数页
    If frm.optPageRange(3).Value Then
        p = vp.PageCount
        If (p Mod 2) = 0 Then
            ReDim strPageRange((p / 2) - 1)
        Else
            ReDim strPageRange((p - 1) / 2)
        End If
        For p = 1 To vp.PageCount Step 2
            strPageRange((p - 1) / 2) = p
        Next p
    End If
    '打印偶数页
    If frm.optPageRange(4).Value Then
        p = vp.PageCount
        If p > 1 Then
            If (p Mod 2) = 0 Then
                ReDim strPageRange((p / 2) - 1)
            Else
                ReDim strPageRange((p - 3) / 2)
            End If
            For p = 2 To vp.PageCount Step 2
                strPageRange((p - 2) / 2) = p
            Next p
            
        End If
    End If
    
    '打印份数
    If vp.Collate Then
        vp.Copies = CInt(frm.strTxtCopyQty)
    End If
    
    Unload frm
    Set frm = Nothing
    
    Call doDraw
    
End Sub

Private Sub DrawText(strContent As String, strLayout As String, strSep As String)
    Dim arrText
    strContent = UCase(Trim(strContent))
    strLayout = UCase(Trim(strLayout))
    strSep = UCase(Trim(strSep))
    
    intCurrentRow = 0: intCurrentCol = 0
    
    arrText = Split(strContent, strSep)
    If UBound(arrText) < 0 Then Exit Sub
    Call GlobleLayOut(strLayout)
    
    Dim i%
    For i = 0 To UBound(arrText)
        If (i Mod 2) = 0 Then
            Call PartLayOut("Label", Trim(arrText(i)), strLayout, Trim(arrText(i)))
        Else
            Call PartLayOut("TextBox", Trim(arrText(i)), strLayout, Trim(arrText(i - 1)))
        End If
    Next i
End Sub

'局部对象布局
Private Sub PartLayOut(TextType As String, strText As String, strLayout As String, Name As String)
    Dim LblAlign$, LblWidth%, LblHeight%, TxtAlign$, TxtWidth%, TxtHeight%, SpanRows%, SpanCols%
    Dim LblOffsetWidth%, TxtOffsetWidth%
    Dim blnBR As Boolean
    blnBR = False
    Dim arrText '存放文本数组
    Dim i%, lngOld_Y&, lngOld_X&
    
    LblAlign = LabelAlign
    LblWidth = LabelWidth       '依照全局变量初始化
    LblHeight = LabelHeight
    TxtAlign = TextAlign
    TxtWidth = lngTextWidth
    TxtHeight = lngTextHeight
    SpanRows = 0
    SpanCols = 0
    LblOffsetWidth = 0
    TxtOffsetWidth = 0
    
    If Trim(strLayout) <> "" Then
        Dim intCharAt%, strTemp$, intCharAtSign%
        strLayout = UCase(Trim(strLayout))
        
        intCharAt = InStr(1, " " & strLayout & " ", " " & Name & " ")    '解析具体对象
        If intCharAt = 0 Then
            intCharAt = InStr(1, " " & strLayout & " ", "|" & Name & " ")    '解析具体对象
        End If
        
        If intCharAt <> 0 Then
            intCharAtSign = InStr(intCharAt, strLayout, "|")
            If intCharAtSign = 0 Then
                strTemp = Mid(strLayout, intCharAt)
            Else
                strTemp = Mid(strLayout, intCharAt, intCharAtSign - intCharAt)
            End If
            
            LblAlign = getValue(LblAlign, "LblAlign", strTemp)
            LblWidth = getValue(LblWidth, "LblWidth", strTemp)
            LblHeight = getValue(LblHeight, "LblHeight", strTemp)
            TxtAlign = getValue(TxtAlign, "TxtAlign", strTemp)
            TxtWidth = getValue(TxtWidth, "TxtWidth", strTemp)
            TxtHeight = getValue(TxtHeight, "TxtHeight", strTemp)
            blnBR = getValue(blnBR, "<BR>", strTemp)
            SpanRows = getValue(SpanRows, "SpanRows", strTemp)
            SpanCols = getValue(SpanCols, "SpanCols", strTemp)
            LblOffsetWidth = getValue(LblOffsetWidth, "LblOffsetWidth", strTemp)
            TxtOffsetWidth = getValue(TxtOffsetWidth, "TxtOffsetWidth", strTemp)
            LabelVisable = getValue(LabelVisable, "LblVisable", strTemp)
            TextVisable = getValue(TextVisable, "TxtVisable", strTemp)
        End If
        
    End If
    
    If TextType = "Label" Then
        intCurrentCol = intCurrentCol + 1
        If intCurrentCol >= Cols Or blnBR Then
            
            intCurrentRow = intCurrentRow + 1
            intCurrentCol = 0
        End If
        
        Dim lngOldCurrentRow&
        lngOldCurrentRow = intCurrentRow    '保存旧行数
        
        If intCurrentCol = 0 Then
           If intCurrentRow > 0 Then
              vp.CurrentY = vp.CurrentY + vp.TextHeight("A") * (1 + RowInterRate) '缝隙
           End If
        End If
        
        If InStr(1, strSpanPoints, "(" & intCurrentRow & "," & intCurrentCol & ")") <> 0 Then
            Call getNextPoint(intCurrentRow, intCurrentCol)     '如发现有行列合并，进行行列合并处理
        End If
        
        vp.CurrentY = vp.CurrentY + vp.TextHeight("A") * (1 + RowInterRate) * (intCurrentRow - lngOldCurrentRow) '缝隙
        
    End If
        
    If TextType = "Label" Then
        lngCurrentX = (intCurrentCol) * ((One_Width * Font_Gap) * (LabelWidth + lngTextWidth) + InterWidth * 2) + lngLeftMargin
        lngCurrentX = lngCurrentX + LblOffsetWidth * (One_Width * Font_Gap)
        
        Select Case UCase(Trim(LblAlign))
        Case "LEFT"
            vp.CurrentX = lngCurrentX
        Case "CENTER"
            vp.CurrentX = lngCurrentX + (One_Width * Font_Gap) * (LabelWidth - LenB(StrConv(strText, vbFromUnicode))) / 2
        Case "RIGHT"
            vp.CurrentX = lngCurrentX + (One_Width * Font_Gap) * (LabelWidth - LenB(StrConv(strText, vbFromUnicode)))
        End Select
                
        If LabelVisable Then
            arrText = getTextArray(strText, LblWidth)
            lngOld_Y = vp.CurrentY
            lngOld_X = vp.CurrentX
            For i = 0 To UBound(arrText)
                vp.Text = arrText(i) & ""
                vp.Text = Chr(13)
                vp.CurrentX = lngOld_X
            Next i
            vp.CurrentY = lngOld_Y
        End If
        
    ElseIf TextType = "TextBox" Then
        lngCurrentX = (intCurrentCol) * ((One_Width * Font_Gap) * (LabelWidth + lngTextWidth) + InterWidth * 2) + (One_Width * Font_Gap) * LabelWidth + InterWidth + lngLeftMargin
        lngCurrentX = lngCurrentX + TxtOffsetWidth * (One_Width * Font_Gap)
        
        Select Case UCase(Trim(TxtAlign))
        Case "LEFT"
            vp.CurrentX = lngCurrentX
        Case "CENTER"
            vp.CurrentX = lngCurrentX + (One_Width * Font_Gap) * (lngTextWidth - LenB(StrConv(strText, vbFromUnicode))) / 2
        Case "RIGHT"
            vp.CurrentX = lngCurrentX + (One_Width * Font_Gap) * (lngTextWidth - LenB(StrConv(strText, vbFromUnicode)))
        End Select
        
        If TextVisable Then
            arrText = getTextArray(strText, TxtWidth)
            lngOld_Y = vp.CurrentY
            lngOld_X = vp.CurrentX
            For i = 0 To UBound(arrText)
                vp.Text = arrText(i) & ""
                vp.Text = Chr(13)
                vp.CurrentX = lngOld_X
            Next i
            vp.CurrentY = lngOld_Y
        End If
    End If
    
    If TextType = "TextBox" Then
        If SpanRows <> 0 Or SpanCols <> 0 Then
            Dim r%, c%
            For r = 0 To SpanRows
                For c = 0 To SpanCols
                    strSpanPoints = strSpanPoints & "(" & intCurrentRow + r & "," & intCurrentCol + c & ")"
                Next c
            Next r
        End If
    End If
    
    Exit Sub
err:
    MsgBox "动态布局出错：" & err.Description, vbInformation, "打印布局"
    
End Sub

'全局对象布局
Private Sub GlobleLayOut(strLayout As String)
    On Error GoTo err
    
    One_Width = vp.TextWidth("A")
    One_Height = vp.TextHeight("A")
    
    '取默认值
    intCurrentCol = -1: intCurrentRow = 0
    lngLeftMargin = vp.MarginLeft: lngTopMargin = 200
    BodyAlign = "Left": InterWidth = 100: InterHeight = 200: Cols = 3
    LabelAlign = "Left": LabelWidth = 10: LabelHeight = 1
    TextAlign = "Left": lngTextWidth = 16: lngTextHeight = 1
    LabelVisable = True: TextVisable = True
    strSpanPoints = ""
    
    If Trim(strLayout) <> "" Then
        Dim intCharAt%, strTemp$, intCharAtSign%
        strLayout = UCase(Trim(strLayout))