frmmodcommonprint.frm

通用书店管理系统

        
        intCharAt = InStr(1, strLayout, "BODY")     '解析BODY
        
        Dim scaleWidth&
        Dim CellWidth&
        scaleWidth = (vp.PageWidth - vp.MarginLeft - vp.MarginRight)
        CellWidth = (One_Width * 1.1) * (LabelWidth + lngTextWidth)
        InterWidth = (scaleWidth - CellWidth * Cols) / (2 * Cols - 1)
            
        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
            
            Cols = getValue(Cols, "Cols", strTemp)
            
            scaleWidth = (vp.PageWidth - vp.MarginLeft - vp.MarginRight)
            CellWidth = (One_Width * Font_Gap) * (LabelWidth + lngTextWidth)
            InterWidth = (scaleWidth - CellWidth * Cols) / (2 * Cols - 1)
            
            BodyAlign = getValue(BodyAlign, "align", strTemp)
            InterWidth = getValue(InterWidth, "InterWidth", strTemp)
            InterHeight = getValue(InterHeight, "InterHeight", strTemp)
        End If
        
        If InterWidth < 10 Then InterWidth = 10
        If InterHeight < 10 Then InterHeight = 10
        
        intCharAt = InStr(1, strLayout, "LABEL")    '解析LABEL
        
        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
            
            LabelAlign = getValue(LabelAlign, "align", strTemp)
            LabelWidth = getValue(LabelWidth, "Width", strTemp)
            LabelHeight = getValue(LabelHeight, "Height", strTemp)
            LabelVisable = getValue(LabelVisable, "Visable", strTemp)
        End If
        
        intCharAt = InStr(1, strLayout, "TEXT")    '解析TEXT
        
        
        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
            
            TextAlign = getValue(TextAlign, "align", strTemp)
            lngTextWidth = getValue(lngTextWidth, "Width", strTemp)
            lngTextHeight = getValue(lngTextHeight, "Height", strTemp)
            TextVisable = getValue(TextVisable, "Visable", strTemp)
        End If
   End If
   
   Dim lngRealWidth&
   lngRealWidth = Cols * ((One_Width * Font_Gap) * (LabelWidth + lngTextWidth) + InterWidth * 2) - InterWidth
   Select Case UCase(Trim(BodyAlign))
   Case "LEFT"
        lngLeftMargin = vp.MarginLeft
   Case "RIGHT"
        If vp.PageWidth > lngRealWidth Then
            lngLeftMargin = vp.MarginLeft + (vp.PageWidth - lngRealWidth - vp.MarginLeft - vp.MarginRight)
        Else
            lngLeftMargin = vp.MarginLeft
        End If
   Case "CENTER"
        If vp.PageWidth > lngRealWidth Then
            lngLeftMargin = vp.MarginLeft + (vp.PageWidth - lngRealWidth - vp.MarginLeft - vp.MarginRight) / 2
        Else
            lngLeftMargin = vp.MarginLeft
        End If
   End Select
   
   Exit Sub
err:
    MsgBox "动态布局出错：" & err.Description, vbInformation, "打印布局"
End Sub

'得到下个坐标
Private Sub getNextPoint(ByRef intCurrentRow As Integer, ByRef intCurrentCol As Integer)
    If intCurrentCol >= Cols Then
        intCurrentRow = intCurrentRow + 1
        intCurrentCol = 0
    Else
        intCurrentCol = intCurrentCol + 1
    End If
    
    If InStr(1, strSpanPoints, "(" & intCurrentRow & "," & intCurrentCol & ")") <> 0 Then
        Call getNextPoint(intCurrentRow, intCurrentCol) '进行递归调用
    Else
        Exit Sub
    End If
    
End Sub

'根据部署描述得到具体值
Private Function getValue(var As Variant, strAim As String, strSource As String)
    On Error GoTo err
    
    strAim = UCase(Trim(strAim))
    Dim intCharAt%
    intCharAt = InStr(1, strSource, strAim)
    If intCharAt = 0 Then getValue = var: Exit Function
    If strAim = "<BR>" Then getValue = True: Exit Function
    
    getValue = g_GetValueByString(var, strAim, strSource)
    
    Exit Function
err:
    MsgBox "控件动态部署出错：" & err.Description, vbInformation, "控件部署"
    
End Function
'设置当前字体
Private Sub setCurrentFont(obj As Object)
    Dim oldY&
    oldY = vp.CurrentY
    With vp
        .FontBold = obj.FontBold
        .FontItalic = obj.FontItalic
        .FontUnderline = obj.FontUnderline
        .FontName = obj.FontName
        .FontSize = obj.FontSize
        .TextColor = obj.ForeColor
        
        One_Width = .TextWidth("A")
        One_Height = .TextHeight("A")
    End With
    vp.CurrentY = oldY
    vp.LineSpacing = One_Height * (0.5)    '设定行间距
End Sub

'画由数组传入的表格
Private Sub DrawTable()
    
    On Error GoTo err
    
    
    Dim strHeader As String
    
    Dim strTableSpanCol As String                               '记录表格列合并信息
    
    intTableBorder = tbAll
    TableLabelVisable = True
    TableTextVisable = True
    
    Dim arr
    With vp
        
        .StartTable
        
        strFormat = g_GetValueByString(strFormat, "Format", PrintInfo.cqTable.LayOut)
        strHeader = g_GetValueByString(strHeader, "Header", PrintInfo.cqTable.LayOut)
        strTableSpanCol = g_GetValueByString(strTableSpanCol, "SpanCol", PrintInfo.cqTable.LayOut)
        strSubtotal = g_GetValueByString(strSubtotal, "Subtotal", PrintInfo.cqTable.LayOut)
        strHeaderMerge = g_GetValueByString(strHeaderMerge, "HeaderMerge", PrintInfo.cqTable.LayOut)
        intTableBorder = g_GetValueByString(intTableBorder, "Border", PrintInfo.cqTable.LayOut)
        TableLabelVisable = g_GetValueByString(TableLabelVisable, "LabelVisable", PrintInfo.cqTable.LayOut)
        TableTextVisable = g_GetValueByString(TableTextVisable, "TextVisable", PrintInfo.cqTable.LayOut)
        
        arrHeader = Split(strHeader, "|")
        Dim arrSpanCol, i&, j&
        '----自动搜索匹配列合并参数
        If Trim(strTableSpanCol) <> "" Then
            arrSpanCol = Split(strTableSpanCol, "|")
            
            Dim arrTemp
            ReDim arrTableSpanCol(UBound(arrSpanCol), 4)
            For i = 0 To UBound(arrSpanCol)
                arrTemp = Split(arrSpanCol(i), ",")
                If IsNumeric(Trim(arrTemp(0))) Then
                    If CInt(Trim(arrTemp(0))) > -1 And CInt(Trim(arrTemp(0))) < UBound(arrHeader) Then
                        arrTableSpanCol(i, 0) = CInt(Trim(arrTemp(0)))
                    Else
                        For j = 0 To UBound(arrHeader)
                            If UCase(Trim(arrHeader(j))) = UCase(Trim(arrTemp(0))) Then
                                arrTableSpanCol(i, 0) = j: Exit For
                            End If
                        Next j
                        If j > UBound(arrHeader) Then
                            arrTableSpanCol(i, 0) = -1      '表示没找到
                        End If
                    End If
                Else
                    For j = 0 To UBound(arrHeader)
                        If UCase(Trim(arrHeader(j))) = UCase(Trim(arrTemp(0))) Then
                            arrTableSpanCol(i, 0) = j: Exit For
                        End If
                    Next j
                    If j > UBound(arrHeader) Then
                        arrTableSpanCol(i, 0) = -1      '表示没找到
                    End If
                End If
                arrTableSpanCol(i, 1) = UCase(Trim(arrTemp(1)))
                arrTableSpanCol(i, 2) = CInt(Trim(arrTemp(2)))
                arrTableSpanCol(i, 3) = CInt(Trim(arrTemp(3)))
                arrTableSpanCol(i, 4) = CInt(Trim(arrTemp(4)))
            Next i
        End If
        
        '----加载表格数组
        arr = PrintInfo.cqTable.Content
        
        '进行数据是否显示处理
        If Not TableLabelVisable Then
            strHeader = ""
            For i = 0 To UBound(arrHeader) - 1
                strHeader = strHeader & "|"
            Next i
        End If
        If Not TableTextVisable Then
            For i = 0 To UBound(arr, 1)
                For j = 0 To UBound(arr, 2)
                    arr(i, j) = ""
                Next j
            Next i
        End If
        
        Dim strTableFormat As String    '表格（列宽和布局）格式化
        Dim arrDataFormat() As String   '数据格式化
        Dim arrViewZero() As String     '是否显示零
        Dim arrFormat() As String
        Dim arrTempFormat() As String
        arrFormat = Split(strFormat, "|")
        ReDim arrDataFormat(UBound(arrFormat))
        ReDim arrViewZero(UBound(arrFormat))
        For i = 0 To UBound(arrFormat)
            arrTempFormat = Split(arrFormat(i), ";")
            If i = UBound(arrFormat) Then
                strTableFormat = strTableFormat & arrTempFormat(0)
            Else
                strTableFormat = strTableFormat & arrTempFormat(0) & "|"
            End If
            If UBound(arrTempFormat) > 0 Then
                arrDataFormat(i) = arrTempFormat(1)
            Else
                arrDataFormat(i) = ""
            End If
            If UBound(arrTempFormat) > 1 Then
                arrViewZero(i) = arrTempFormat(2)
            End If
        Next i
        
        '数据列格式化
        For i = 0 To UBound(arrDataFormat)
            If arrDataFormat(i) <> "" And Trim(arrViewZero(i)) = "否" Then
                For j = 0 To UBound(arr, 2)
                    If Abs(CDbl(arr(i, j))) > 0.000001 Then
                        arr(i, j) = Format(arr(i, j), arrDataFormat(i))
                    Else
                        arr(i, j) = ""
                    End If
                Next j
            ElseIf arrDataFormat(i) <> "" Then
                For j = 0 To UBound(arr, 2)
                    arr(i, j) = Format(arr(i, j), arrDataFormat(i))
                Next j
            ElseIf Trim(arrViewZero(i)) = "否" Then
                For j = 0 To UBound(arr, 2)
                    If Abs(CDbl(arr(i, j)) - 0) <= 0.000001 Then
                        arr(i, j) = ""
                    End If
                Next j
            End If
        Next i
        strFormat = strTableFormat
        
        '让数据居中显示
        strFormat = Replace(strFormat, "+", "")
        strFormat = "+" & Replace(strFormat, "|", "|+")
        
        '加载数组
        .AddTableArray strFormat, strHeader, arr
        
        '表格的边线
        .TableBorder = intTableBorder
        
        '----表格列头居中
        For i = 0 To UBound(arrHeader)
            .TableCell(tcAlign, 0, i + 1) = 7
        Next i
                
        '----列合并
        Dim relRow&
        relRow = .TableCell(tcRows)
        If TypeName(arrTableSpanCol) = "Variant()" Then
            '根据变量值进行行定位
            For i = 0 To UBound(arrTableSpanCol, 1)
                If InStr(1, arrTableSpanCol(i, 1), "MAXROW") = 0 And (Not IsNumeric(arrTableSpanCol(i, 1))) Then
                    For j = 1 To relRow
                        If .TableCell(tcText, j, CInt(arrTableSpanCol(i, 0))) = arrTableSpanCol(i, 1) Then
                            arrTableSpanCol(i, 1) = j
                        End If
                    Next j
                End If
            Next i
            '合并指定的单元
            For i = 0 To UBound(arrTableSpanCol, 1)
                If IsNumeric(Trim(arrTableSpanCol(i, 1))) Then
                    If CInt(arrTableSpanCol(i, 0)) > -1 And CInt(arrTableSpanCol(i, 0)) < UBound(arrHeader) Then _
                        .TableCell(tcColSpan, CLng(arrTableSpanCol(i, 1)), CInt(arrTableSpanCol(i, 0)) + CInt(arrTableSpanCol(i, 2))) = CInt(arrTableSpanCol(i, 3))
                        .TableCell(tcAlign, CLng(arrTableSpanCol(i, 1)), CInt(arrTableSpanCol(i, 0)) + CInt(arrTableSpanCol(i, 2))) = CInt(arrTableSpanCol(i, 4))
                Else
                    If InStr(1, Trim(arrTableSpanCol(i, 1)), "MAXROW") <> 0 Then
                        
                        If Len(Trim(arrTableSpanCol(i, 1))) <> 6 Then
                            
                            relRow = relRow + Val(Mid(Trim(arrTableSpanCol(i, 1)), 7))
                            .TableCell(tcColSpan, relRow, CInt(arrTableSpanCol(i, 0)) + CInt(arrTableSpanCol(i, 2))) = CInt(arrTableSpanCol(i, 3))
                            .TableCell(tcAlign, relRow, CInt(arrTableSpanCol(i, 0)) + CInt(arrTableSpanCol(i, 2))) = CInt(arrTableSpanCol(i, 4))
                        Else
                            .TableCell(tcColSpan, relRow, CInt(arrTableSpanCol(i, 0)) + CInt(arrTableSpanCol(i, 2))) = CInt(arrTableSpanCol(i, 3))
                            .TableCell(tcAlign, relRow, CInt(arrTableSpanCol(i, 0)) + CInt(arrTableSpanCol(i, 2))) = CInt(arrTableSpanCol(i, 4))
                        End If
                    End If
                End If
            Next i
        End If
        
        '----调整行高
        Dim FixedRowHeight As Double
        If Row_Height = 0 Then  '如果行高未指定，启用默认行高
            Row_Height = CDbl(.TableCell(tcRowHeight, 0, .TableCell(tcRows)))
        End If
        FixedRowHeight = g_GetValueByString(FixedRowHeight, "RowHeight", PrintInfo.cqTable.LayOut)
        If FixedRowHeight <> 0 Then '如果有指定固定行高，启用固定行高
            Row_Height = FixedRowHeight
        End If
        .TableCell(tcRowHeight, 0, , .TableCell(tcRows)) = Row_Height
        
        '计算每页最大行