preview.frm

文档编程软件,类似WORD的一个编辑工具.

        Else
            .Visible = False
            imgCorner.Visible = False
        End If
    End With
    
    With hscPreview
'决定水平滚动条是否需要显示
        If picChild.Width > picParent.Width Then
            .Visible = True
            .Max = picChild.Width - picParent.ScaleWidth
            .Min = 0
            .LargeChange = picChild.Width - picParent.ScaleWidth
            imgCorner.Visible = True
        Else
            .Visible = False
            imgCorner.Visible = False
        End If
    End With

End Sub

Public Sub SizePreview(lWidth As Long, lHeight As Long)

    Dim iCount As Integer
    
    For iCount = 0 To picPreview.Count - 1
        With picPreview(iCount)
            .Left = 0
            .Top = 0
            .Width = lWidth
            .Height = lHeight
        End With
    Next
    picChild.Move 0, 0, lWidth, lHeight
    
End Sub

Private Sub abPreview_ComboSelChange(ByVal tool As ActiveBar2LibraryCtl.tool)
    If bLoad = False Then
        With tool
            ScalePercent = CInt(Left(.CBList(.CBListIndex), Len(.CBList(.CBListIndex)) - 1))
        End With
        PictureShow
    End If
End Sub

Private Sub abPreview_ToolClick(ByVal tool As ActiveBar2LibraryCtl.tool)
    Select Case tool.Name
    Case "miPrint":
        PreviewPrint
        Unload Me
    Case "miZoomIn":
        PreviewZoomIn
    Case "miZoomOut":
        PreviewZoomOut
    Case "miClose":
        Unload Me
    Case "miPage":
        With picPreview(tool.TagVariant - 1)
            .Picture = .Image
            picChild.Picture = .Picture
            PictureShow
        End With
                
    End Select
End Sub


Private Sub Form_Activate()
    m_ab.Bands("barFormat").Visible = False
    m_ab.Bands("barStandard").Visible = False
    m_ab.Bands("barTaskbar").Visible = False
    m_ab.RecalcLayout
    '显示第一页
    With picPreview(0)
        .Picture = .Image
        picChild.Move 0, 0, .Width, .Height
        picChild.Picture = .Picture
        PictureShow
    End With
End Sub

Private Sub Form_Deactivate()
    m_ab.Bands("barFormat").Visible = True
    m_ab.Bands("barStandard").Visible = True
    m_ab.Bands("barTaskbar").Visible = True
    m_ab.RecalcLayout
End Sub

Private Sub Form_Load()
    bLoad = True
    FillCboPercent
    ScalePercent = 100
    WindowState = vbMaximized
    bLoad = False
    abPreview.ClientAreaControl = picParent
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    m_ab.Bands("barFormat").Visible = True
    m_ab.Bands("barStandard").Visible = True
    m_ab.Bands("barTaskbar").Visible = True
    m_ab.RecalcLayout
    Me.WindowState = vbNormal
End Sub

Private Sub hscPreview_Change()
    picChild.Left = (-hscPreview.Value)
End Sub

Private Sub hscPreview_Scroll()
    picChild.Left = (-hscPreview.Value)
End Sub

Private Function IMDIDocument_CommandHandler(tool As ActiveBar2LibraryCtl.ITool) As Boolean
    IMDIDocument_CommandHandler = False
End Function

Private Function IMDIDocument_InitDoc(ab As ActiveBar2LibraryCtl.IActiveBar2, sFile As String, bNew As Boolean) As Boolean
    Set m_ab = ab

    ab.RegisterChildMenu Me.hWnd, "mnuPreview"
    Me.Caption = sFile & " 预览"
    Me.Show
End Function

Private Sub picParent_Resize()
    
    Dim iCount As Integer
    
    With picParent
        '设置垂直滚动条
        vscPreview.Move .ScaleLeft + .ScaleWidth - vscPreview.Width, .ScaleTop, vscPreview.Width, .ScaleHeight - hscPreview.Height

        '设置水平滚动条
        hscPreview.Move 0, .ScaleHeight - hscPreview.Height, .ScaleWidth - vscPreview.Width

        imgCorner.Move vscPreview.Left, hscPreview.Top
    End With
    ResizeScrollBars
    
End Sub

Private Sub vscPreview_Change()
    picChild.Top = (-vscPreview.Value)
End Sub

Private Sub vscPreview_Scroll()
    picChild.Top = (-vscPreview.Value)
End Sub

Public Sub PrintPreview(rtf As RichTextBox, LeftMarginWidth As Currency, _
    TopMarginHeight As Currency, RightMarginWidth As Currency, BottomMarginHeight As Currency, _
    pgOrientation As Integer, Optional ToPrinter As Boolean = False)
      
    Dim LeftOffset As Long, TopOffset As Long
    Dim LeftMargin As Long, TopMargin As Long
    Dim RightMargin As Long, BottomMargin As Long
    Dim fr As FormatRange
    Dim rcDrawTo As Rect
    Dim rcPage As Rect
    Dim TextLength As Long
    Dim NextCharPosition As Long
    Dim r As Long
    Dim iCount As Integer

    On Error GoTo ErrHandle
    
'设置打印机的打印方向
    Printer.Orientation = pgOrientation
    Printer.ScaleMode = vbTwips

    If ToPrinter Then Printer.Print Space(1)

    '计算左边距、右边距、上边距和下边距
    LeftMargin = CLng(LeftMarginWidth - LeftOffset)
    TopMargin = CLng(TopMarginHeight - TopOffset)
    RightMargin = CLng((Printer.Width - RightMarginWidth) - LeftOffset)
    BottomMargin = CLng((Printer.Height - BottomMarginHeight) - TopOffset)

    '设置可打印区的范围
    rcPage.Left = 0
    rcPage.Top = 0
    rcPage.Right = Printer.ScaleWidth
    rcPage.Bottom = Printer.ScaleHeight

    '设置在哪一个打印机中的打印区(相对于可打印区)
    rcDrawTo.Left = LeftMargin
    rcDrawTo.Top = TopMargin
    rcDrawTo.Right = RightMargin
    rcDrawTo.Bottom = BottomMargin

    
    '设置打印指示
    If ToPrinter Then
        fr.hdc = Printer.hdc   '使用同样的设备描述体来测量和绘制
        fr.hdcTarget = Printer.hdc  '指向打印机的设备描述体
    Else
        '调整打印预览图片框的大小
        Me.SizePreview Printer.Width, Printer.Height
        fr.hdc = picPreview(0).hdc   '使用同样的设备描述体来测量和绘制
        fr.hdcTarget = picPreview(0).hdc  '指向打印机的设备描述体
    End If
    fr.rc = rcDrawTo            '指出要绘制的页面的区域
    fr.rcPage = rcPage          '指出指出整个页面的大小
    fr.chrg.cpMin = 0           '指出从头到尾的开始的文字
    fr.chrg.cpMax = -1          '文字的结束

'获得 RTF 控件中文字的数量
    TextLength = Len(rtf.Text)

'循环打印直到打印完成
    Dim iPage As Integer
    
    iPage = 1
    
    Do
        If ToPrinter Then
            '发送 EM_FORMATRANGE 消息来打印页面
            NextCharPosition = SendMessage(rtf.hWnd, EM_FORMATRANGE, True, fr)
            If NextCharPosition >= TextLength Then Exit Do  '如果完成就退出
            fr.chrg.cpMin = NextCharPosition '下一页的开始位置
            Printer.NewPage  '继续打印下一页
            Printer.Print Space(1) '重新初始化设备描述体
            fr.hdc = Printer.hdc
            fr.hdcTarget = Printer.hdc
        Else
            AddPage iPage
            If iPage > 1 Then
                fr.hdc = picPreview(iPage - 1).hdc
                fr.hdcTarget = picPreview(iPage - 1).hdc
            End If
            picPreview(iPage - 1).Print
        

            '发送 EM_FORMATRANGE 消息来打印页面
            NextCharPosition = SendMessage(rtf.hWnd, EM_FORMATRANGE, True, fr)
            If NextCharPosition >= TextLength Then Exit Do  '如果完成就退出
            fr.chrg.cpMin = NextCharPosition '下一页的开始位置
        
            iPage = iPage + 1
        End If
    Loop

    '让 RTF 控件释放内存
    r = SendMessage(rtf.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))

    If ToPrinter Then
        Printer.EndDoc
    Else
        Me.Show
    End If

    Exit Sub
    
ErrHandle:
    Select Case Err.Number
        Case 482
            MsgBox "确定你已经有一个已经安装好的打印机。如果一个打印机已" & _
            "经安装好，请在“设置”页面设置打印机属性，并且确定 ICM 检查" & _
            "框已经被选中，然后再试一次。", , "打印机错误"
            Exit Sub
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Resume Next
    End Select
    
End Sub