frmpreview.frm

超经典的打印预览动态库源码 版权： 本资源版权归作者所有 说明： 本资源由源码天空搜集,仅提供学习参考

    picTb.Cls
    
    picTb.Top = 0
    picTb.left = 0
    picTb.width = Me.width - 150
    picTb.height = tbOperate.height + 60
    
    picTb.Line (60, 50)-Step(0, picTb.height - 120), vbWhite
    picTb.Line (90, 50)-Step(0, picTb.height - 120), &H808080
    picTb.Line (120, 50)-Step(0, picTb.height - 120), vbWhite
    picTb.Line (150, 50)-Step(0, picTb.height - 120), &H808080
    
    picTb.Line (0, 0)-Step(picTb.width - 20, 0), vbWhite
    picTb.Line (0, picTb.height - 20)-Step(picTb.width - 10, 0), &H808080
    picTb.Line (0, 10)-Step(0, picTb.height - 20), vbWhite
    picTb.Line (picTb.width - 20, 10)-Step(0, picTb.height - 10), &H808080
    
    'tbOperate.width = picTb.width - 200
    
    picTb.Line (0, picTb.height - 30)-Step(picTb.width, 5), &H808080, BF
    picTb.Line (0, picTb.height - 20)-Step(picTb.width, 0), vbBlack, BF
End Sub


'**************************************************************
'*名称：DrawBK
'*功能：绘制预览区
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-08 15:43:50
'***************************************************************
Private Sub DrawBK()
On Error Resume Next
    picBK.Cls
    
    '*调整位置
    picBK.Top = picTb.Top + picTb.height
    picBK.left = 0
    picBK.height = Me.height - picBK.Top - 420 - 280
    picBK.width = Me.width - 150 - 280
    
    '调整内部控件的位置
    picBot.left = 15
    picBot.width = picBK.width - 20 + 280
    picBot.height = 250 + 30
    picBot.Top = picBK.Top + picBK.height
    
    HS.Top = 0
    HS.left = 2000 + 50
    HS.width = picBot.width - 2000 - 310
    HS.height = 250
    
    labInfo.left = 10
    labInfo.Top = 40
    labInfo.height = 200
    labInfo.width = 2000
    
    prg.left = 30
    prg.Top = 40
    prg.height = 200
    prg.width = 2000
    
    picRight.Top = picBK.Top
    picRight.left = picBK.width
    picRight.height = picBK.height
    picRight.width = 280
    
    VS.Top = 0
    VS.left = 0
    VS.height = picRight.height
    VS.width = 250
    
    '*绘制一个内陷的边框
    
    'picBK.Line (15, 0)-Step(0, picBK.height), vbBlack, BF
    
    '*绘制底部的边框
    picBot.Cls
    picBot.Line (0, 0)-Step(2050, 6), vbBlack, BF
    
    picBot.Line (0, picBot.height - 10)-Step(picBot.width, 0), vbWhite
    picBot.Line (0, picBot.height - 30)-Step(picBot.width, 0), &H808080
    picBot.Line (picBot.width - 10, 10)-Step(0, picBot.height - 20), vbWhite
    picBot.Line (picBot.width - 30, 10)-Step(0, picBot.height - 20), &H808080
    
    picRight.Line (picRight.width - 15, 0)-Step(0, picRight.height), vbWhite
    picRight.Line (picRight.width - 30, 0)-Step(0, picRight.height), &H808080
End Sub

Private Sub Form_Resize()
'限定缩放的最小范围

    If Me.width < 6000 Then
        Me.width = 6000
    End If
    If Me.height < 4200 Then
        Me.height = 4200
    End If
    DrawTb
    DrawBK
    If Not bInit Then
        ScrollSet
        ShowPage
    End If
End Sub

'**************************************************************
'*名称：ScrollSet
'*功能：设置滚动条
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-08 20:33:11
'***************************************************************
Private Sub ScrollSet()
    
'*横向的处理
Dim aWidth      As Single
Dim uWidth      As Single
    
    '*页的宽度
    aWidth = rpt.width * sRate + 100
    uWidth = picBK.width
    
    '*首先判断可以横向显示几个页面
    iPageCnt = Fix(uWidth / aWidth)
    If iPageCnt = 0 Then iPageCnt = 1
    
    '*300作为一个大的change，而一个小的change为10
    If aWidth <= uWidth Or iPageCnt > 1 Then
        HS.Max = 0
    Else
        If CLng((aWidth - uWidth) / 10) <> (aWidth - uWidth) / 10 Then
            HS.Max = CLng((aWidth - uWidth) / 10 + 0.499999999)
        Else
            HS.Max = (aWidth - uWidth) / 10
        End If
    End If
    
    HS.SmallChange = 10
    HS.LargeChange = 300
    
'*竖向的处理
Dim aHeight     As Single
Dim uHeight     As Single
    
    '*所有页面的长度(页面的高度加上上下共100的空间
    aHeight = rpt.pages * rpt.cutpages * (rpt.height * sRate + 100) / iPageCnt
    '*当前可用的显示区域
    uHeight = picBK.height
    
    '*300作为一个大的change，而一个小的change为10
    If aHeight <= uHeight Then
        VS.Max = 0
    Else
        If CLng((aHeight - uHeight) / 10) <> (aHeight - uHeight) / 10 Then
            VS.Max = CLng((aHeight - uHeight) / 10 + 0.499999999)
        Else
            VS.Max = (aHeight - uHeight) / 10
        End If
    End If

    VS.SmallChange = 10
    VS.LargeChange = 300
    
    ShowInfo
End Sub

'**************************************************************
'*名称：ShowPage
'*功能：根据当前的value决定要显示哪些页面
'*传入参数：
'*      bClear          --是否要先清除所有的页面
'*作者：chlf78
'*日期：2002-04-08 22:38:33
'***************************************************************
Private Sub ShowPage(Optional bClear As Boolean = False)
Dim uHeight         As Single
Dim pHeight         As Single
Dim lstPFrom        As Integer
Dim lstPTo          As Integer
Dim i               As Integer
Dim iCutPages       As Integer
Dim cutpage         As Integer
    picBK.Visible = False
    lstPFrom = pFrom
    lstPTo = pTo
    
    uHeight = picBK.height
    pHeight = rpt.height * sRate + 100
    
    '*得到要显示的页面

    pFrom = Fix(VS.Value / pHeight * 10) * iPageCnt + 1

    pTo = (Fix(VS.Value / pHeight * 10 + uHeight / pHeight) + 1) * iPageCnt

    '*将新的要显示的页面加载
    iCutPages = rpt.ColHeader.cutpages
    
    If pFrom = 0 Then
        pFrom = 1
    End If

    If pTo > rpt.Content.GetPages * iCutPages Then
        pTo = rpt.Content.GetPages * iCutPages
    End If
    
    On Error Resume Next

    For i = lstPFrom To lstPTo
        If ((i < pFrom Or i > pTo) And i <> 0) Or bClear Then
            '*在窗体的resize事件时不能缷载控件，所以只能不可见处理：(
            picPage(i).Visible = False
            Unload picPage(i)
        End If
    Next i

    On Error GoTo 0
    For i = pFrom To pTo
    
        If i < lstPFrom Or i > lstPTo Or bClear Then
            On Error Resume Next        '*上面的缷载未完成：(所以...
            Load picPage(i)
            On Error GoTo 0
            '*得到页数
            cutpage = i Mod iCutPages
            If cutpage = 0 Then
                cutpage = iCutPages
            End If
            '*输出到控件
            PrintIt picPage(i), Int(i / iCutPages + 0.9999999), cutpage, sRate

        End If
        
        '*调整纵向位置
        picPage(i).Top = Fix((i - 1) / iPageCnt) * pHeight - CLng(VS.Value) * 10 + 50

    Next i

    HMove
    
End Sub


'**************************************************************
'*名称：HMove
'*功能：横向移动滚动条的处理
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-09 14:07:55
'***************************************************************
Private Sub HMove()
Dim i           As Integer
Dim aWidth      As Single
Dim uWidth      As Single
Dim left        As Single
    '*调整位置
    aWidth = rpt.width * sRate + 100
    uWidth = picBK.width

    For i = pFrom To pTo
        If HS.Max = 0 Then '*如果能够显示得下，就居中
            left = (uWidth - aWidth * iPageCnt) / 2 + 50
            '*
        Else
            left = -HS.Value * 10 + 50
        End If
        picPage(i).left = ((i - 1) Mod iPageCnt) * aWidth + left
        picPage(i).Visible = True
    Next i
    picBK.Visible = True
End Sub


Private Sub HS_Change()
    HMove
End Sub

Private Sub HS_Scroll()
    Call HS_Change
End Sub

Private Sub picPage_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    picBK.MouseIcon = LoadResPicture("MOVE", vbResCursor)

    lstX = x
    lstY = y
End Sub

Private Sub picPage_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    '*则移动
        On Error Resume Next
        HS.Value = HS.Value + (lstX - x) / 10
        VS.Value = VS.Value + (lstY - y) / 10
        On Error GoTo 0
        ShowPage

    picBK.MouseIcon = LoadResPicture("ARROW", vbResCursor)

End Sub

Private Sub rpt_InitProgress(Value As Integer)
    prg.Value = Value
End Sub

Private Sub tbOperate_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.key
        Case "printer"      '*输出到打印机
            Dim fExport2Prn         As New frmExport2Prn
            
            Set fExport2Prn.rpt = rpt
            
            
            fExport2Prn.Show vbModal, Me
            
            Set fExport2Prn = Nothing
            
        Case "export"
            Call tbOperate_ButtonMenuClick(Button.ButtonMenus("jpg"))
            
        Case "set"
            Dim fSet                As New frmSet
            
            Set fSet.rpt = rpt
            
            fSet.Show vbModal, Me
            
            Set fSet = Nothing
            
            '*重新显示
            ScrollSet
            ShowPage True
        Case "margin"   '*在页面上显示页边距
            bMargin = Not bMargin
            ShowPage True
            
        Case "zoom"     '*缩放比例
            Dim btnMenu             As MSComctlLib.ButtonMenu
            If Button.tag = "" Then
                Set btnMenu = Button.ButtonMenus(4)
            Else
                If Button.tag = Button.ButtonMenus.Count Then
                    Set btnMenu = Button.ButtonMenus(1)
                Else
                    Set btnMenu = Button.ButtonMenus(Button.tag + 1)
                End If
            End If

            Call tbOperate_ButtonMenuClick(btnMenu)
            
            Button.tag = btnMenu.Index
            
        Case "quit"
            Unload Me

        Case Else
            
            
    End Select
End Sub

Private Sub tbOperate_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)
    If left(ButtonMenu.key, 1) = "r" Then

        Dim mRate           As Single
        
        If ButtonMenu.tag <> "no" Then
            mRate = CSng(ButtonMenu.tag)
        Else
        
            Dim uWidth      As Single       '*可用宽度
            Dim uHeight     As Single       '*可用高度
            Dim pWidth      As Single       '*页面宽度
            Dim pHeight     As Single       '*页面高度
            
            uWidth = picBK.width
            uHeight = picBK.height
            
            pWidth = rpt.width + 100
            pHeight = rpt.height + 100
            
            Select Case ButtonMenu.key
                Case "rpage"        '*整页
                    mRate = uWidth / pWidth
                    If mRate > uHeight / pHeight Then
                        mRate = uHeight / pHeight
                    End If
                Case "rwidth"       '*页宽
                    mRate = uWidth / pWidth
                Case "rdblpage"     '*双页
                    mRate = uWidth / (pWidth + 50) / 2
                    
                Case Else
            End Select
        End If
        
        '*设置新的缩放比例
        sRate = mRate
        
        '*重新显示
        ScrollSet
        ShowPage True
        
        tbOperate.Buttons("zoom").Caption = ButtonMenu.text
        Exit Sub
    End If
    
    '*输出
    Select Case ButtonMenu.key
        Case "excel"        '*输出到Excel
        
        Case "jpg"          '*输出到JPG
            Dim fExport2Jpg         As New frmExport2Jpg
            
            Set fExport2Jpg.rpt = rpt
            
            fExport2Jpg.Show vbModal, Me
            
            Set fExport2Jpg = Nothing
            
        Case Else
        
    End Select
End Sub

Private Sub VS_Change()
    ShowPage
End Sub

Private Sub VS_Scroll()
    Call VS_Change
End Sub


'**************************************************************
'*名称：ShowInfo
'*功能：显示相关信息
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-10 23:53:36
'***************************************************************
Private Sub ShowInfo()
Dim str         As String

    str = CLng(rpt.width / UNIT * 10) & "×" & CLng(rpt.height / UNIT * 10)
    str = str & " " & rpt.pages & "页" & rpt.cutpages & "分页"
    labInfo.Caption = str
End Sub