preview3.frm

来自「这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写」· FRM 代码 · 共 1,949 行 · 第 1/5 页

End Sub

Private Sub mWriteText(X As Double, Y As Double, OutText As String)
    
    VsPreview.CurrentX = X
    VsPreview.CurrentY = Y
    VsPreview.Text = OutText
    
End Sub

Private Sub mControlSize()

    Dim minHeight       As Integer
    Dim minWidth        As Integer
    Dim EdgeWidth       As Integer
    Dim tlHeight        As Integer
    Dim stbHeight       As Integer
    
    minHeight = 4000
    minWidth = 8500
    EdgeWidth = 80
    tlHeight = IIf(Toolbar1.Visible, Toolbar1.Height, 0)
    stbHeight = IIf(stb.Visible, stb.Height, 0)
    
    If Me.Height < minHeight Then Me.Height = minHeight
    If Me.Width < minWidth Then Me.Width = minWidth
    
    Frame1.left = EdgeWidth
    Frame1.Width = Me.ScaleWidth - EdgeWidth * 2
    
    Toolbar1.Width = Frame1.Width - EdgeWidth * 2
    
    VsPreview.left = EdgeWidth
    VsPreview.Top = Frame1.Top + Frame1.Height + EdgeWidth
    
    VsPreview.Width = Me.ScaleWidth - EdgeWidth * 2
    VsPreview.Height = Me.ScaleHeight - VsPreview.Top - stbHeight

End Sub

Private Function mstrGetField() As String
'***********************************************************
'
'Purpose:
'        取得标题的字段及调整页边距
'
'***********************************************************

    Dim iCount          As String
    Dim TmpFmt          As String
    Dim tmpField        As String
    Dim iSep            As Integer
    Dim tmpTable        As String
    Dim UsefulWidth     As Integer
    Dim i               As Integer
    Dim EdgeWidth       As Integer
    Dim bOK             As Boolean
    
    On Error GoTo ErrGetField
    
    bOK = False
    iSep = VsPreview.Marginleft * 2
    EdgeWidth = 50
    
    If gDataSourceType = abLvw Then 'abLvw Then
        tmpTable = gFormatfields
                
    ElseIf gDataSourceType = abVsf Then
        tmpTable = gFormatfields
        
    ElseIf gDataSourceType = abString Then
    
    '当数据是从表中取得时
    ElseIf gDataSourceType = abDB Then
        tmpTable = gFormatfields
    End If
        
    mstrGetField = tmpTable
    Exit Function
ErrGetField:
    mstrGetField = ""
    MsgBox Me.Caption & vbCrLf & "读取字段名错误 mstrGetField"
    Err.Clear
    
End Function

Private Function mstrGetContent(strField As String) As String
'***************************************************************
'
'Purpose:
'       读取要打印的内容
'
'******************************************************************
    Dim tmpContent          As String
    Dim TmpFmt              As String
    Dim iCount              As Integer
    Dim iRows               As Integer
    Dim i                   As Integer
    Dim J                   As Integer
    
    On Error GoTo ErrGetContent
    
    If gDataSourceType = abLvw Then
        iCount = glvwItemData.ColumnHeaders.Count
        For i = 1 To glvwItemData.ListItems.Count
            tmpContent = tmpContent & glvwItemData.ListItems(i).Text & "|"
            For J = 1 To iCount - 1
                tmpContent = tmpContent & glvwItemData.ListItems(i).SubItems(J) & "|"
            Next J
            tmpContent = tmpContent & ";"
        Next i
    ElseIf gDataSourceType = abVsf Then
        
        iCount = gvsfItemData.Cols
        iRows = gvsfItemData.Rows
        For i = 1 To iRows - 1
            tmpContent = tmpContent & gvsfItemData.TextMatrix(i, 0) & "|"
            For J = 1 To iCount - 1
                tmpContent = tmpContent & gvsfItemData.TextMatrix(i, J) & "|"
            Next J
            tmpContent = Mid(tmpContent, 1, Len(tmpContent) - 1) & ";"
        Next i
    
    ElseIf gDataSourceType = abString Then
    ElseIf gDataSourceType = abDB Then
        Do While gRs.EOF = False
            For i = 0 To gRs.Fields.Count - 1
                tmpContent = tmpContent & gRs.Fields(i) & "|"
            Next i
            tmpContent = Mid(tmpContent, 1, Len(tmpContent) - 1) & ";"
            gRs.MoveNext
        Loop
    End If
    
    iCount = Len(strField)
    For i = 1 To iCount
        If Mid(strField, i, 1) = ";" Then
            TmpFmt = Mid(strField, 1, i)
            Exit For
        End If
    Next i
    mstrGetContent = TmpFmt & tmpContent
    Exit Function
ErrGetContent:
    mstrGetContent = ""
    gShowMsg Me.Caption & vbCrLf & "读取内容错误 mstrGetContent"
            
End Function

Private Function miSetTitle(strField As String) As Integer
    Dim iHeaderHei      As Integer
    Dim iSpace          As Integer
    Dim OldSize         As Integer
    Dim TableWidth      As Integer
    iSpace = 100
    
    With VsPreview
        .CalcTable = strField
        TableWidth = .TextWid
        OldSize = .FontSize
        .FontSize = 15
        .FontBold = True
        .CurrentX = (.PageWidth - .TextWidth(gTitle)) / 2
        .CurrentY = .MarginTop 'IIf(.MarginTop > 800, 800, .MarginTop)
        .Text = gTitle

        iHeaderHei = .TextHeight(gTitle)
        
'        .FontName = "宋体"
        .FontSize = OldSize
        .FontBold = False
        .CurrentX = (.PageWidth - TableWidth) / 2
        .CurrentY = .CurrentY + iHeaderHei + iSpace
        .TextAlign = taLeftTop
        .Text = gLeftTop
        .CurrentX = .PageWidth - (.PageWidth - TableWidth) / 2 - .TextWidth(gMidTop) / 2 - TableWidth / 2
'        .TextAlign = taJustMiddle
        .Text = gMidTop
'        .TextAlign = taRightTop
        .CurrentX = .PageWidth - (.PageWidth - TableWidth) / 2 - .TextWidth(gRightTop) - iSpace
        .Text = gRightTop
        miSetTitle = .CurrentY + .TextHeight(gLeftTop) + iSpace
    End With
        
End Function

Private Function miSetSubHeader(HeaderHei As Integer, strField As String) As Integer
'**************************************************
'
'Purpose:
'       预览,打印内容
'
'**************************************************
    Dim iCol            As Integer
    Dim StartX          As Integer
    Dim StartY          As Integer
    Dim TableWidth      As Integer
    Dim iSep            As Integer
    Dim iRow            As Integer
    Dim RowHeight       As Integer
    Dim i               As Integer
    Dim J               As Integer
    Dim tmpHeader       As String
    Dim iCount          As Integer
    Dim Col2X           As Integer
    Dim Col3X           As Integer
    
    iSep = 50
    
    RowHeight = VsPreview.TextHeight("测试字高")
    
    
    VsPreview.TextAlign = taCenterTop
    VsPreview.CalcTable = strField
    
    TableWidth = VsPreview.TextWid
    StartX = VsPreview.X1
    StartY = HeaderHei + iSep * 2
    iCol = 0
    iCount = Len(gMuliHeaders)
    J = 1
    For i = 1 To iCount
        If Mid(gMuliHeaders, i, 1) = "|" Then
            iCol = iCol + 1
            tmpHeader = Mid(gMuliHeaders, J, i - J)
            If iCol = 1 Then
                VsPreview.CurrentX = StartX
            ElseIf iCol = 2 Then
                If iRow = 0 Then
                    Col2X = (VsPreview.PageWidth - VsPreview.TextWidth(tmpHeader)) / 2
                    VsPreview.CurrentX = Col2X
                Else
                    VsPreview.CurrentX = Col2X
                End If
'            ElseIf iCol = 3 Then
'                If iRow = 0 Then
'                    Col3X = vsPreview.PageWidth - vsPreview.MarginRight - vsPreview.TextWidth(tmpHeader)
'                    vsPreview.CurrentX = Col3X
'                Else
'                    vsPreview.CurrentX = Col3X
'                End If
            Else
                VsPreview.CurrentX = VsPreview.PageWidth - (VsPreview.PageWidth - TableWidth) / 2 - VsPreview.TextWidth(tmpHeader)
            End If
            
            VsPreview.CurrentY = StartY + iRow * (RowHeight + iSep) '* IIf(iRow > 0, 1, 0)
                
            VsPreview.TextAlign = taLeftTop
            VsPreview.Text = tmpHeader
            J = i + 1
        ElseIf Mid(gMuliHeaders, i, 1) = ";" Then
            iCol = 0
            iRow = iRow + 1
            J = J + 1
        End If
        
    Next i
    
    miSetSubHeader = VsPreview.CurrentY + iSep
    
    Exit Function
ErrSetSubHeader:
    miSetSubHeader = 0
    Screen.MousePointer = vbDefault
    gShowMsg Me.Caption & vbCrLf & " 预览内容错误 mbSetSubHeader "
End Function

Private Sub mSetStringTable(HeaderHei As Integer)
    
   Dim iCol            As Integer
    Dim StartX          As Integer
    Dim StartY          As Integer
    Dim TableWidth      As Integer
    Dim iSep            As Integer
    Dim iRow            As Integer
    Dim RowHeight       As Integer
    Dim i               As Integer
    Dim J               As Integer
    Dim tmpHeader       As String
    Dim iCount          As Integer
    Dim Col2X           As Integer
    Dim Col3X           As Integer
    
    Col2X = 0
    Col3X = 0
    iSep = 50
    
    RowHeight = VsPreview.TextHeight("测试字高")
    
    StartX = VsPreview.Marginleft
    StartY = HeaderHei + iSep * 2
    iCol = 0
    iCount = Len(gMuliHeaders)
    J = 1
    For i = 1 To iCount
        If Mid(gMuliHeaders, i, 1) = "|" Then
            iCol = iCol + 1
            tmpHeader = Mid(gMuliHeaders, J, i - J)
            If iCol = 1 Then
                VsPreview.CurrentX = StartX
            ElseIf iCol = 2 Then
                If Col2X = 0 Then
                    Col2X = (VsPreview.PageWidth - VsPreview.TextWidth(tmpHeader)) / 2 - 1000
                    VsPreview.CurrentX = Col2X
                Else
                    VsPreview.CurrentX = Col2X
               End If
            ElseIf iCol = 3 Then
                If Col3X = 0 Then
                    Col3X = VsPreview.PageWidth - VsPreview.MarginRight - VsPreview.Marginleft - VsPreview.TextWidth(tmpHeader) - 1000
                    VsPreview.CurrentX = Col3X
                Else
                    VsPreview.CurrentX = Col3X
                End If
            Else
                VsPreview.CurrentX = VsPreview.PageWidth - (VsPreview.PageWidth - TableWidth) / 2 - VsPreview.TextWidth(tmpHeader)
            End If
            
            VsPreview.CurrentY = StartY + iRow * (RowHeight + iSep) '* IIf(iRow > 0, 1, 0)
                
            VsPreview.TextAlign = taLeftTop
            VsPreview.Text = tmpHeader
            J = i + 1
        ElseIf Mid(gMuliHeaders, i, 1) = ";" Then
            iCol = 0
            iRow = iRow + 1
            J = J + 1
        End If
        
    Next i
    
    
    Exit Sub
ErrSetSubHeader:
    Screen.MousePointer = vbDefault
    gShowMsg Me.Caption & vbCrLf & " 预览内容错误 mbSetSubHeader "
    
    
End Sub

Private Function mbPrintDataSource() As Boolean
'********************************************************
'
'   打印结果集数据
    Dim iCount          As Integer
    Dim i               As Integer
    Dim TmpFmt          As String
    Dim TmpHead         As String
    Dim strBody         As String
    Dim tmpContent      As String
    
    Do While gRs.EOF = False
        For i = 0 To gRs.Fields.Count - 1
            tmpContent = tmpContent & gRs.Fields(i) & "|"
        Next i
        tmpContent = Mid(tmpContent, 1, Len(tmpContent) - 1) & ";"
        gRs.MoveNext
    Loop
    
    
    iCount = Len(gFormatfields)
    For i = 1 To iCount
        If Mid(gFormatfields, i, 1) = ";" Then
            TmpFmt = Mid(gFormatfields, 1, i)
            TmpHead = Mid(gFormatfields, i + 1, iCount - i)
            Exit For
        End If
    Next i
    VsPreview.StartTable
    VsPreview.AddTable TmpFmt, TmpHead, tmpContent
'    vspreview.TableCell(tcAlign) =
'    vspreview.TableCell(tcRowHeight, 0) = ".8in"
    VsPreview.TableCell(tcFontBold, 0) = True
    VsPreview.TableCell(tcFontItalic, 0) = False
    'vspreview.TableCell(tcBackColor, 0) = vbBlue
'    vspreview.TableCell(tcRowHeight) = "0.3in"

'    vspreview.TableCell(tcRowHeight) = "0.8in"
'    Set vspreview.TableCell(tcRowSource) = gRs
    VsPreview.EndTable
    
    
End Function

Private Sub mSetPrintParam()
'***********************************
'设置打印参数
    
'    vspreview.StartDoc
'    vspreview.EndDoc