frmprint.frm

这是本人用vb配合access数据库开发的一个部门人事管理的一个小软件的源码。

VERSION 5.00
Object = "{E228A480-FDCB-11D5-A3C8-0050BF074C3F}#2.0#0"; "curtPrinter.ocx"
Begin VB.Form frmPrint 
   Caption         =   "Print"
   ClientHeight    =   6630
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   10215
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   6630
   ScaleWidth      =   10215
   Begin VB.CommandButton Command1 
      Caption         =   "纸张方向"
      Height          =   615
      Left            =   7080
      TabIndex        =   1
      Top             =   0
      Width           =   1335
   End
   Begin CurtPrinter打印预览控件.CurtPrinter CurtPrinter1 
      Height          =   1695
      Left            =   1080
      TabIndex        =   0
      Top             =   1800
      Width           =   8055
      _ExtentX        =   14208
      _ExtentY        =   2990
      Orientation     =   2
      PaperWidth      =   16839.9
      PaperHeight     =   11907
      LeftMargin      =   567
      RightMargin     =   567
      ForeColor       =   -2147483640
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmPrint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'打印内容代码。预览或打印都是调用该代码的，也是大部分打印方法的演示
Public Sub PrintContent(Optional PrintDevice As Printer)
    If Not PrintDevice Is Nothing Then
        CurtPrinter1.StartPrint PrintDevice  '打印到打印机
    Else
        CurtPrinter1.StartPrint  '缺省是预览
    End If
    With CurtPrinter1
        
    '第一页，编程打印，其实也是非常简单
     '   .NewPage
     '   .TitleOut "自定义打印测试（标题居中）", 15, vbCenter '打印标题
     '   .TextOut "打印表格测试（默认字体设置）："
     '   .NewRow
         
         '打印表格
     '   .Font.Bold = True: .FontSize = 14 '此处不要用.Font.Size，否则缩放会出问题
     '   .CellOut "姓名", 2000, vbLeftJustify, "2211", vbGrayText
     '   .CellOut "年龄", 1000, vbCenter, "1211", vbGrayText
     '   .CellOut "简介", 6000, , "1221", vbGrayText
     '   .NewCellRow
     '   .Font.Bold = False: .FontSize = 12 '此处不要用.Font.Size，否则缩放会出问题
     '   .CellOut "王小二", 2000, vbLeftJustify, "2111"
     '   .CellOut "22", 1000, vbCenter, "1111"
     '   .CellOut "无业游民，喜欢偷鸡摸狗", 6000, , "1121"
     '   .NewCellRow
     '   .CellOut "王小三", 2000, vbLeftJustify, "2112"
     '   .CellOut "33", 1000, vbCenter, "1112"
     '   .CellOut "程序员，电脑的奴隶，但从不破坏工具来进行抵抗", 6000, , "1122"
     '   .NewCellRow: .ForeColor = vbBlue
     '   .TextOut "紧贴表格打印一行彩色文字"
     '   .NewRow: .ForeColor = vbBlack
     '   .NewRow
     '   .TextOut "跳过一行打印文字"
        
        '一些图形方法的演示
       ' .FilledBoxOut 2 * .ScaleWidth / 3, 2 * .ScaleHeight / 3, 3 * .ScaleWidth / 5, 3 * .ScaleHeight / 5, vbBlue
     '   .CircleOut .ScaleWidth / 2, .ScaleHeight / 2, 1000
       ' .LineOut 0, 0, .ScaleWidth, .ScaleHeight '可打印的范围
       ' .LineOut .ScaleWidth, 0, 0, .ScaleHeight
       ' .PictureOut Image1.Picture, 2400, 2400, Image1.Width, Image1.Height
      '  .BoxOut 0, 0, .ScaleWidth, .ScaleHeight, vbRed
        
    '重新开始一页，直接打印报表，注意，它会自动换页，如果你设定了标题，它也自动打哦:)
        .NewPage
        
        '直接打印MSFlexGrid
       
        '.TitleOut "The Employees' Working Hours Table of CO PL"
        .TitleOut frmCheckChart.lblTitle
        .DirectPrint frmCheckChart.msgList
         
        '.NewRow
        
        '直接打印MSHFlexGrid
       ' .TitleOut "直接打印MSHFlexGrid的测试，居中对齐"
       ' .DirectPrint MSHFlexGrid1, "测试MSFLEXGRID"
        '.NewRow
        
        '根据控件的DirectPrint方法写的代码，大家可以参考来写自己的DirectPrint方法
       ' .NewPage
        
       ' .TitleOut "直接打印ListView的测试，居中对齐"
       '  RefDirectPrint frmCheckChart.msgList, "测试LISTVIEW"
       ' .NewRow
       ' 支持DATEGRID的直接打印，用法同上，不提供例子了
    
    '结束打印
        .EndDoc
    End With
End Sub

Private Sub mnuExit_Click()
    Unload Me
End Sub

'预览的代码
Private Sub mnuPreview_Click()
    CurtPrinter1.Visible = True
  
    PrintContent
End Sub
'两行代码可选，一个会调用打印对话框，一个直接打印了。
Private Sub mnuPrint_Click()
    CurtPrinter1.ShowPrinter
    'PrintContent Printer
End Sub

Private Sub Command1_Click()
CurtPrinter1.Orientation = IIf(CurtPrinter1.Orientation = 1, 2, 1)
End Sub

'点击了预览控件上的关闭，引发该事件，关闭预览窗体
Private Sub curtprinter1_ClosePreview()
    CurtPrinter1.Visible = False
   
End Sub
'如果每次调整预览比例好重新生成预览的话，请将AutoRedraw设置为FALSE，然后在下面的事件添入要重画的代码
Private Sub curtprinter1_NeedRedraw()
  
    PrintContent
    
End Sub
'写入打印叶脚的代码
Private Sub curtprinter1_PrintFooter(CurrentPage As Long)
    CurtPrinter1.FooterOut "SSME", "CO PL", "第" & CurrentPage & "页"
End Sub
'写入打印页眉的代码
Private Sub curtprinter1_PrintHeader(CurrentPage As Long)
    CurtPrinter1.HeaderOut "SSME", "CO PL", Date
End Sub
'点击了预览窗体或直接调用ShowPrinter后，点击了打印机窗口的确定，引发打印代码，打印到打印机上！
Private Sub curtprinter1_RealPrint()
    PrintContent Printer
End Sub


'预览控件尺寸根据窗口调整
Private Sub Form_Resize()
    CurtPrinter1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If CurtPrinter1.Busy = True Then '打印预览控件忙则取消打印任务，然后就可以退出了
        CurtPrinter1.CancelPrint
        MsgBox "打印控件忙，稍后重试。", vbInformation
        Cancel = True
    End If
        
End Sub

'添加数据到控件，以测试打印预览
Private Sub Form_Load()

   
    
End Sub


'大家打印自己的控件可参考下面代码(从DirectPrint修改而来）
Private 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, CurtPrinter1.Font
    CloneFont CurtPrinter1.Font, objToPrint.Font
    If Not CurtPrinter1.IsPrinter Then CurtPrinter1.Font.Size = CurtPrinter1.FontSize * CurtPrinter1.Zoom / 100
    
    With objToPrint
        If TypeName(objToPrint) = "ListView" Then
            '先打印ColumnHeaders
            If .ListItems.Count < 1 Or .View < 3 Then GoTo EndP
            CurtPrinter1.CellOut .ColumnHeaders(1).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4422", vbButtonFace '边缘单元格
            For j = 2 To .ColumnHeaders().Count - 1
                CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2422", vbButtonFace '边缘单元格
            Next j
            CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2442", vbButtonFace '边缘单元格
            CurtPrinter1.NewCellRow
            
            '打印实际表格部分
            For i = 1 To .ListItems.Count - 1
                If CurtPrinter1.CurrentY + TextHeight("人") * 3 > CurtPrinter1.ScaleHeight - CurtPrinter1.TopMargin - CurtPrinter1.BottomMargin Then
                    
                    '最后一行的单元格
                    CurtPrinter1.CellOut .ListItems(i).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4224"
                    For j = 1 To .ListItems(i).ListSubItems().Count - 1
                        CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2224"
                    Next j
                    CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2244"
                    
                    '重新打印表头
                    CurtPrinter1.NewPage
                    If TITLE <> "" Then CurtPrinter1.TitleOut TITLE, tFontSize, titleAlignment
                    CurtPrinter1.CellOut .ColumnHeaders(1).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4422", vbButtonFace   '边缘单元格
                    For j = 2 To .ColumnHeaders().Count - 1
                        CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2422", vbButtonFace  '边缘单元格
                    Next j
                    CurtPrinter1.CellOut .ColumnHeaders(j).Text, .ColumnHeaders(j).Width, vbCenter, "2442", vbButtonFace  '边缘单元格
                Else
                    
                    '打印非边缘的单元格
                    CurtPrinter1.CellOut .ListItems(i).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4222"
                    For j = 1 To .ListItems(i).ListSubItems().Count - 1
                        CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2222"
                    Next j
                    CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2242"
                End If
                CurtPrinter1.NewCellRow
            Next i
            '打印最后一行
            CurtPrinter1.CellOut .ListItems(i).Text, .ColumnHeaders(1).Width, vbLeftJustify, "4224"
            For j = 1 To .ListItems(i).ListSubItems().Count - 1
                CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2224"
            Next j
            CurtPrinter1.CellOut .ListItems(i).ListSubItems(j).Text, .ColumnHeaders(j + 1).Width, vbCenter, "2244"
        End If
    End With
    
EndP:
    '恢复打印控件原来使用的字体
    CloneFont CurtPrinter1.Font, oldFont
    Set oldFont = Nothing
End Sub
'复制字体属性
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