previous.frm

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

                    bOK = True
                    Exit Do
                End If
            Loop
        Loop
                
    ElseIf gDataSourceType = abVsf Then
        iCount = gvsfItemData.Cols
        Do Until bOK
        
            For I = 0 To iCount - 1
                tmpFmt = tmpFmt & "<+" & vsPreview.TextWidth(gvsfItemData.TextMatrix(0, I))
                tmpField = tmpField & gvsfItemData.TextMatrix(0, I) & "|"
            Next I
            tmpFmt = Mid(tmpFmt, 1, Len(tmpFmt) - 1) & ";"
            tmpField = Mid(tmpField, 1, Len(tmpField) - 1) & ";"
            tmpTable = tmpFmt & tmpField
            vsPreview.CalcTable = tmpTable
            
            Do Until False
                UsefulWidth = vsPreview.PageWidth - vsPreview.Marginleft - vsPreview.MarginRight
                If vsPreview.Marginleft <= EdgeWidth And iSep > EdgeWidth Then
                    iSep = iSep / 2
                    bOK = False
                    Exit Do
                ElseIf iSep <= EdgeWidth Then
                    vsPreview.FontSize = vsPreview.FontSize - 1
                    bOK = False
                    Exit Do
                ElseIf UsefulWidth < vsPreview.TextWid Then
                    vsPreview.Marginleft = vsPreview.Marginleft / 2
                    vsPreview.MarginRight = vsPreview.MarginRight / 2
                Else
                    bOK = True
                    Exit Do
                End If
            Loop
        Loop
        
    ElseIf gDataSourceType = abDB Then
    
    End If
        
'    tmpFmt = Mid(tmpFmt, 1, Len(tmpFmt) - 1) & ";"
'    tmpField = Mid(tmpField, 1, Len(tmpField) - 1) & ";"
'    tmpTable = tmpFmt & tmpField
'    VSPreview.CalcTable = tmpTable
    
    '调整页边距
'    Do Until False
'        UsefulWidth = vspreview.PageWidth - VSPreview.MarginLeft - VSPreview.MarginRight
'        If VSPreview.MarginLeft <= EdgeWidth And iSep > EdgeWidth Then
'            iSep = iSep / 2
'            bOK = False
'            Exit Do
'        ElseIf iSep <= EdgeWidth Then
'            VSPreview.FontSize = 8
'            bOK = False
'            Exit Do
'        ElseIf UsefulWidth < VSPreview.TextWid Then
'            VSPreview.MarginLeft = VSPreview.MarginLeft / 2
'            VSPreview.MarginRight = VSPreview.MarginRight / 2
'        Else
'            Exit Do
'        End If
'    Loop
    
    mstrGetField = tmpTable
    Exit Function
ErrGetField:
    mstrGetField = ""
    gshowmsg Me.Caption & vbCrLf & "读取字段名错误 mstrGetField"
    
End Function

Private Function mstrGetContent(strField As String) As String
'***************************************************************
'
'Purpose:
'       读取要打印的内容
'
'******************************************************************
    Dim tmpContent          As String
    Dim tmpFmt              As String
    Dim iCount              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
        For I = 1 To gvsfItemData.Rows - 1
            For J = 1 To iCount - 1
                tmpContent = tmpContent & gvsfItemData.TextMatrix(I, J) & "|"
            Next J
            tmpContent = tmpContent & ";"
        Next I
    ElseIf gDataSourceType = abDB Then
    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 = 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)
        .Text = gRightTop
        miSetTitle = .CurrentY + .TextHeight(gLeftTop) + iSpace
    End With
        
End Function

Private Function mbSetPreview() As Boolean
'**************************************************
'
'Purpose:
'       预备览打印内容
'
'**************************************************

    Dim strField        As String
    Dim strContent      As String
    Dim LinePos         As String
    Dim iTitleHeight    As Integer
    Dim iHeaderHei      As Integer
    Dim StartY          As Integer
    Dim iSep            As Integer
    
    On Error GoTo ErrSetPreview
    
    iSep = 100
    
'    If iTitleHeight = 0 Then mbSetPreview = False: Exit Function
    mbBeginLine = False
    mbEndLine = True
    vsPreview.StartDoc
    
   ' VSPreview.Font.Name = "宋体"
    vsPreview.FontName = "宋体"
    mbBeginLine = True
    '取得TABLE的字段
    strField = mstrGetField()
    mstrField = strField
    '取得TABLE的内容
    strContent = mstrGetContent(strField)
    '显示标题
    iTitleHeight = miSetTitle(strField)
    
    With vsPreview
    
        '显示字段名
        .TextAlign = taCenterTop
        .CurrentX = .Marginleft
        .CurrentY = iTitleHeight + iSep * 2
'        .FontBold = True
        .TableBorder = tbNone
        .Table = strField
        
        '画两条分隔线
        .CalcTable = strField
        .CurrentX = .X1
'        .CurrentY = .CurrentY + .TextHei
        StartY = .CurrentY + iSep
        LinePos = .X1 & " " & StartY & " " & .X2 & " " & StartY
        .Polyline = LinePos
        LinePos = .X1 & " " & StartY + 40 & " " & .X2 & " " & StartY + 40
        .Polyline = LinePos
        
        '显示内容
        .CurrentX = .Marginleft
        .CurrentY = .CurrentY + iSep * 2 + 40
        .TableBorder = tbNone
        .FontBold = False
        .Table = strContent
        
        '画两条分隔线
        .CalcTable = strContent
        .CurrentX = .Marginleft
        StartY = .CurrentY + iSep
        LinePos = .X1 & " " & StartY & " " & .X2 & " " & StartY
        .Polyline = LinePos
        LinePos = .X1 & " " & StartY + 40 & " " & .X2 & " " & StartY + 40
        .Polyline = LinePos

        '显示尾注
'        .MarginFooter = .PageHeight - .Y2 - 100
        .Footer = gLeftBottom & "|" & gMidBottom & "|" & gRightBottom

    End With
    mbEndLine = False
    vsPreview.EndDoc
    
    mbSetPreview = True
    Exit Function
ErrSetPreview:
    mbSetPreview = False
    vsPreview.KillDoc
    Screen.MousePointer = vbDefault
    gshowmsg Me.Caption & vbCrLf & "预览错误 mbSetPreview"
                        
End Function

Private Sub mSetLinePos(bEnd As Boolean)
'******************************************************
'
'Purpose:
'       设置除最后一页外的页尾线，和除第一页外的字段
'
'*******************************************************

    Dim StartY          As Integer
    Dim StartX1         As Integer
    Dim EndX2           As Integer
    Dim LinePos         As String
    Dim iSep            As Integer
    
    iSep = 100
    
    If bEnd Then
        StartY = vsPreview.PageHeight - vsPreview.MarginBottom + iSep
        StartX1 = vsPreview.X1
        EndX2 = vsPreview.X2
        LinePos = StartX1 & " " & StartY & " " & EndX2 & " " & StartY
        vsPreview.Polyline = LinePos
        LinePos = StartX1 & " " & StartY + 40 & " " & EndX2 & " " & StartY + 40
        vsPreview.Polyline = LinePos
        
    Else
        vsPreview.CalcTable = mstrField
        vsPreview.CurrentX = vsPreview.X1
        vsPreview.CurrentY = vsPreview.MarginTop - vsPreview.TextHei * 2 - iSep
        vsPreview.Table = mstrField
        
        StartY = vsPreview.CurrentY + iSep
        StartX1 = vsPreview.X1
        
        EndX2 = vsPreview.X2
        LinePos = StartX1 & " " & StartY & " " & EndX2 & " " & StartY
        vsPreview.Polyline = LinePos
        LinePos = StartX1 & " " & StartY + 40 & " " & EndX2 & " " & StartY + 40
        vsPreview.Polyline = LinePos
        
        vsPreview.CurrentY = vsPreview.MarginTop
        
    End If
    
        
        
    
End Sub


Private Function mbSetPrint() As Boolean
'    VSPreview.Action = paChoosePrintAll
'    VSPreview.Action = paChoosePrinter
    If vsPreview.PrintDialog(pdPrinterSetup) Then
        Call mbSetPreview
    End If
End Function
Private Function mbPrint() As Boolean
    
    vsPreview.Preview = False
    vsPreview.Collate = colFalse
    Call mbSetPreview
    
End Function

Private Sub cmdClose_Click()
    Unload Me
End Sub

Private Sub cmdPrint_Click()
    Call mbPrint
End Sub

Private Sub Form_Activate()
    If Not mbSetPreview() Then Unload Me
End Sub

Private Sub Form_Load()
    
    center Me
'    vsPreview.PaperSize = pprA4
'    vsPreview.PhysicalPage = False

    vsPreview.MarginBottom = gMargin.MarginBottom
    vsPreview.MarginTop = gMargin.MarginTop
    vsPreview.Marginleft = gMargin.Marginleft
    vsPreview.MarginRight = gMargin.MarginRight
    vsPreview.PaperBin = binAuto
    
    vsPreview.Preview = True
    
    KeyPreview = True
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If gDataSourceType = abLvw Then
        Set glvwItemData = Nothing
    ElseIf gDataSourceType = abVsf Then
        Set gvsfItemData = Nothing
    End If
End Sub

Private Sub Form_Resize()
    Call mControlSize
End Sub



Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    If Button.Key = "tlSetPrint" Then
        Call mbSetPrint
    ElseIf Button.Key = "tlExit" Then
        Unload Me
    ElseIf Button.Key = "tlFirstPage" Then
    ElseIf Button.Key = "tlPrevPage" Then
        vsPreview.PreviewPage = vsPreview.PreviewPage - 1
    ElseIf Button.Key = "tlNextPage" Then
        vsPreview.PreviewPage = vsPreview.PreviewPage + 1
    ElseIf Button.Key = "tlLastPage" Then
    ElseIf Button.Key = "tlHelp" Then
    ElseIf Button.Key = "tlZoomOut" Then
    ElseIf Button.Key = "tlZoomIn" Then
    End If
    
End Sub

Private Sub VSPreview_EndPage()
    If mbEndLine Then Call mSetLinePos(True)
End Sub

Private Sub VSPreview_NewPage()
    If mbBeginLine Then Call mSetLinePos(False)
End Sub