frmpreview.frm

ktv场所的包房开房、迎宾、预定管理系统。

    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          --是否要先清除所有的页面
'*作者：progame
'*日期：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
'*功能：横向移动滚动条的处理
'*传入参数：
'*
'*作者：progame
'*日期：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 Form_Unload(Cancel As Integer)
    Set m_HS = Nothing
    Set m_VS = Nothing
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)
Dim sx       As Long
Dim sy       As Long
    '*则移动
        'On Error Resume Next
        sx = HS.Value + (lstX - X) / 10
        sy = VS.Value + (lstY - Y) / 10
        If sx <= 0 Then sx = 0
        If sx > HS.Max Then sx = HS.Max
        If sy <= 0 Then sy = 0
        If sy > VS.Max Then sy = VS.Max
        HS.Value = sx
        VS.Value = sy

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

End Sub

Private Sub rpt_InitProgress(Value As Integer)
    'flatProgressBar1.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

End Sub

Private Sub VS_Change()
    ShowPage
End Sub

Private Sub VS_Scroll()
    Call VS_Change
End Sub


'**************************************************************
'*名称：ShowInfo
'*功能：显示相关信息
'*传入参数：
'*
'*作者：progame
'*日期：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