frmpreview.frm

地理信息系统工程案例精选程序,本书所有案例均需要单独配置

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{E228A480-FDCB-11D5-A3C8-0050BF074C3F}#2.0#0"; "curtPrinter.ocx"
Begin VB.Form frmPreview 
   Caption         =   "数据打印"
   ClientHeight    =   7770
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9750
   Icon            =   "frmPreview.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   7770
   ScaleWidth      =   9750
   StartUpPosition =   1  '所有者中心
   Begin CurtPrinter打印预览控件.CurtPrinter CPrinter 
      Height          =   7215
      Left            =   0
      TabIndex        =   1
      Top             =   480
      Width           =   9735
      _ExtentX        =   17171
      _ExtentY        =   12726
      ForeColor       =   -2147483640
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ToolBarVisible  =   0   'False
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 abPreview 
      Align           =   1  'Align Top
      Height          =   495
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   9750
      _LayoutVersion  =   1
      _ExtentX        =   17198
      _ExtentY        =   873
      _DataPath       =   ""
      Bands           =   "frmPreview.frx":08A6
   End
End
Attribute VB_Name = "frmPreview"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub CloneFont(Dest As StdFont, Src As StdFont)
    '复制字体
    With Dest
        .Bold = Src.Bold
        .Charset = Src.Charset
        .Italic = Src.Italic
        .Name = Src.Name
        .Size = Src.Size
        .Strikethrough = Src.Strikethrough
        .Underline = Src.Underline
        .Weight = Src.Weight
    End With
End Sub

Private Sub abPreview_TextChange(ByVal Tool As ActiveBar2LibraryCtl.Tool)
'放大系数被改变
Select Case Tool.Name
    Case "Factor"
        CPrinter.Zoom = Val(Mid(Tool.text, 1, Len(Tool.text) - 1))
End Select

End Sub

Private Sub abPreview_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
'工具栏按钮被单击
Select Case Tool.Name
    Case "Print"
        '打印
        CPrinter.StartPrint
    Case "Setup"
        '打印设置
        CPrinter.PageSetup
    Case "PageTop"
        '到第一页
        CPrinter.PageUp
    Case "PageUp"
        '到上一页
        CPrinter.PageUp
    Case "PageDown"
        '到下一页
        CPrinter.PageDown
    Case "PageButtom"
        '到最后一页
        CPrinter.PageDown
    Case "ZoomIn"
        '放大
        CPrinter.ZoomIn
        abPreview.Bands("bStandard").Tools("Factor").text _
            = Format(CPrinter.Zoom) & "%"
    Case "ZoomOut"
        '缩小
        CPrinter.ZoomOut
        abPreview.Bands("bStandard").Tools("Factor").text _
            = Format(CPrinter.Zoom) & "%"
    Case "Exit"
        '推出
        Unload Me
End Select
  
End Sub

Public Sub RefDirectPrint(objToPrint As Object, _
                            Optional TITLE As String, _
                            Optional tFontSize As Long = 12, _
                            Optional titleAlignment As AlignmentConstants = vbCenter)

'生成报表
    Dim i As Long, J As Long, K As Long, oldFont As New StdFont
    CloneFont oldFont, CPrinter.Font
    CloneFont CPrinter.Font, objToPrint.Font
    If Not CPrinter.IsPrinter Then CPrinter.Font.Size = CPrinter.FontSize * CPrinter.Zoom / 100
    frmMain.Progress_Enable
    With objToPrint
        If TypeName(objToPrint) = "ListView" Then
            
            If .ListItems.Count < 1 Or .View < 3 Then GoTo EndP
            '生成表头
            For J = 2 To .ColumnHeaders().Count
                CPrinter.CellOut .ColumnHeaders(J).text, .ColumnHeaders(J).Width, vbCenter, "1111", vbButtonFace
            Next J
            
            CPrinter.NewCellRow
            '向报表中填充数据
            For i = 1 To .ListItems.Count
                If CPrinter.CurrentY + TextHeight("人") * 3 > CPrinter.ScaleHeight - CPrinter.TopMargin - CPrinter.BottomMargin Then
                    For J = 1 To .ListItems(i).ListSubItems().Count
                        CPrinter.CellOut .ListItems(i).ListSubItems(J).text, .ColumnHeaders(J + 1).Width, vbCenter, "1111"
                    Next J
                    CPrinter.NewPage
                    For J = 2 To .ColumnHeaders().Count
                        CPrinter.CellOut .ColumnHeaders(J).text, .ColumnHeaders(J).Width, vbCenter, "1111", vbButtonFace
                    Next J
                Else
                    For J = 1 To .ListItems(i).ListSubItems().Count
                        CPrinter.CellOut .ListItems(i).ListSubItems(J).text, .ColumnHeaders(J + 1).Width, vbCenter, "1111"
                    Next J
                End If
                CPrinter.NewCellRow
                DoEvents
                frmMain.Progress_SetValue CDbl(i), CDbl(.ListItems.Count)
            Next i
        End If
    End With
    
EndP:
    '恢复打印控件原来使用的字体
    CloneFont CPrinter.Font, oldFont
    frmMain.Progress_Disable
    Set oldFont = Nothing
End Sub

Private Sub abPreview_ToolKeyPress(ByVal Tool As ActiveBar2LibraryCtl.Tool, KeyAscii As Long)
KeyAscii = 0
End Sub

Private Sub CPrinter_NeedRedraw()
PrintContent
End Sub

Private Sub CPrinter_PrintFooter(CurrentPage As Long)
'页角设置
CPrinter.FooterOut "", "", ""
End Sub

Private Sub CPrinter_PrintHeader(CurrentPage As Long)
页头设置
CPrinter.HeaderOut "报表", "交通事故地理信息系统", "第" & CurrentPage & "页"
End Sub

Private Sub CPrinter_RealPrint()
'打印到打印机
    PrintContent Printer
End Sub

Private Sub Form_Resize()

If Me.WindowState <> 1 Then
    '窗体改变大小,打印控件随着改变大小
    If frmPreview.Width < 2500 Then frmPreview.Width = 2500
    If frmPreview.Height < 2400 Then frmPreview.Height = 2400
    
    CPrinter.Width = frmPreview.ScaleWidth
    CPrinter.Height = frmPreview.ScaleHeight - abPreview.Height

End If


End Sub
Public Sub PrintContent(Optional PrintDevice As Printer)
    '打印到打印机
    If Not PrintDevice Is Nothing Then
        frmMain.SetTipText "正在准备打印，请稍候..."
        CPrinter.StartPrint PrintDevice  '打印到打印机
    Else
        frmMain.SetTipText "正在准备打印预览，请稍候..."
        CPrinter.StartPrint  '缺省是预览
    End If
    With CPrinter
        .NewPage
        RefDirectPrint frmTrackSearch.lstInfo
        .NewRow
        .EndDoc
    End With
    frmMain.SetTipText "完毕"
End Sub
Private Sub Form_Unload(Cancel As Integer)
    If CPrinter.Busy = True Then
        CPrinter.CancelPrint
        MsgBox "打印控件忙，稍后重试。", vbInformation
        Cancel = True
    End If
        
End Sub