preview.frm

自定报表组件

    PageTo = cboPage.ListCount
    Msg = PageFrom
    If PageFrom < PageTo Then
      Msg = Msg & "," & PageTo
    End If
    Msg = Trim(InputBox("请输入您要打印的页面范围，如：1," & cboPage.ListCount & "。", "打印连续页", Msg, L, T))
    If Len(Msg) = 0 Then
      Exit Sub
    End If
    
    On Error Resume Next
    L = InStr(Msg, ",")
    PageTo = Val(Mid(Msg, L + 1))
    If L = 0 Then
      PageFrom = PageTo
    Else
      PageFrom = Val(Left(Msg, L - 1))
    End If
    If (PageFrom < 1) Or (PageFrom > PageTo) Or (PageTo > cboPage.ListCount) Then
      MsgBox "您输入的打印页范围无效，请重新输入！", vbOKOnly, gPreviewCaption
      PageFrom = 0
      PageTo = -1
    End If
  End If
  
  If PageFrom > 0 Then
    SetMP 11
    devPrinter = True
    Set devPrintTo = Printer
    With Printer
      If Not PaperChangedByUser Then
        .PaperSize = gPaperSize
        .Orientation = gOrientation
      End If
      .ScaleMode = vbMillimeters
      W = .ScaleWidth / sqrPrintScale
      H = .ScaleHeight / sqrPrintScale
    End With
    Printer.Scale (0, 0)-(W, H)
    
    PrintCancel = False
    For I = PageFrom To PageTo
      If I > PageFrom Then
        Printer.NewPage
      End If
      PrintPage I
      If PrintCancel Then Exit For
    Next I
    If PrintCancel Then
      Printer.KillDoc
    Else
      Printer.EndDoc
    End If
    
    devPrinter = False
    Set devPrintTo = picPreview
    SetMP 0
  End If
End Sub

Private Sub cmdPrintCancel_Click()
  If MsgBox("您确定要取消本次打印操作?   ", vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then PrintCancel = True
End Sub

Private Sub cmdPrinter_Click()
  On Error Resume Next
  With cdlPrinter
    .CancelError = True
    .Flags = cdlPDPrintSetup
    .Action = 5
  End With
  If Err = 0 Then
    PaperChangedByUser = True
    gPaperSize = Printer.PaperSize
    gOrientation = Printer.Orientation
    RefreshPaper 0, 0
  End If
End Sub

Private Sub Form_Activate()
  Me.Refresh
  If gPreviewShow Then
    RefreshPaper 0, 0
  Else
    cmdPrint_Click -1
    Unload Me
  End If
End Sub

Private Sub Form_Load()
  Dim I As Long
  Dim Value As Single
  Dim Msg As String
  
  CenterForm Me
  
  PaperChangedByUser = False
  
  devPrinter = False
  Set devPrintTo = picPreview
  
  RefreshNow = False
  
  For I = 0 To gPreviewPageCount - 1
    cboPage.AddItem Trim(arrPreviewPage(I).Name) & " (" & I + 1 & " of " & gPreviewPageCount & ")"
  Next I
  
  Msg = GetSetting(App.EXEName, "Preview", "Offset1", "0")
  Value = Val(Msg)
  Offset1 = Value
  
  Msg = GetSetting(App.EXEName, "Preview", "Offset2", "0")
  Value = Val(Msg)
  Offset2 = Value
  
  Msg = GetSetting(App.EXEName, "Preview", "Offset3", "0")
  Value = Val(Msg)
  Offset3 = Value
  
  Msg = GetSetting(App.EXEName, "Preview", "PreviewScale", "100%")
  Value = Val(Msg)
  Msg = Right("   " & Format(Value, "0"), 3) & "%"
  
  On Error Resume Next
  cboPreviewScale = Msg
  If Err > 0 Then cboPreviewScale = "100%"
  
  Msg = GetSetting(App.EXEName, "Preview", "PrintScale", "100%")
  Value = Val(Msg)
  Msg = Right("   " & Format(Value, "0"), 3) & "%"
  On Error Resume Next
  cboPrintScale = Msg
  If Err > 0 Then
    cboPrintScale.AddItem Msg
    cboPrintScale = Msg
  End If
  
  cboPage.ListIndex = 0
  
  CellWidth = 1
  CellHeight = 1
  
  RefreshNow = True
  
  SetMP 0
End Sub

Private Sub Form_Resize()
  If (Me.Width < 2100) Or (Me.Height < 2100) Then
    RefreshNow = False
    If Me.Width < 2100 Then
      Me.Width = 2100
    End If
    If Me.Height < 2100 Then
      Me.Height = 2100
    End If
  Else
    RefreshNow = True
    picBoard.Height = Me.Height - 15 * 56
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  SaveSetting App.EXEName, "Preview", "Offset1", Offset1
  SaveSetting App.EXEName, "Preview", "Offset2", Offset2
  SaveSetting App.EXEName, "Preview", "Offset3", Offset3
  SaveSetting App.EXEName, "Preview", "PreviewScale", cboPreviewScale
  SaveSetting App.EXEName, "Preview", "PrintScale", cboPrintScale
  Set devPrintTo = Nothing
  Set frmPreview = Nothing
End Sub

Private Sub hsrPreview_Change()
  ViewMove
End Sub

Private Sub picBoard_Resize()
  Dim Tmp As Long
  Dim W As Long
  Dim H As Long
  Dim WView As Long
  Dim HView As Long
  
  If Not RefreshNow Then Exit Sub
  
  WView = picPreview.Width + BorderSpace * 2 + 270
  HView = picPreview.Height + BorderSpace * 2 + 270
  W = picBoard.Width
  H = picBoard.Height
  
  With hsrPreview
    Tmp = WView - W
    If Tmp > TwipsMove Then
      .Max = Tmp / TwipsMove
      Tmp = Int(W / 3 / TwipsMove)
      .LargeChange = IIf(Tmp > .Max, .Max, Tmp)
      .Visible = True
    Else
      .Visible = False
      .Value = 0
    End If
  End With
  
  With vsrPreview
    Tmp = HView - H
    If Tmp > TwipsMove Then
      .Max = Tmp / TwipsMove
      Tmp = Int(H / 3 / TwipsMove)
      .LargeChange = IIf(Tmp > .Max, .Max, Tmp)
      .Visible = True
    Else
      .Visible = False
      .Value = 0
    End If
  End With
  
  cmdCorner.Visible = hsrPreview.Visible And vsrPreview.Visible
  cmdCorner.Move W - 330, H - 330, 270, 270
  
  hsrPreview.Move 0, H - 330, W - 330 + IIf(cmdCorner.Visible, 0, 270), 270
  
  vsrPreview.Move W - 330, 0, 270, H - 330 + IIf(cmdCorner.Visible, 0, 270)

  ViewMove
End Sub

Private Sub picPreview_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim RefreshRequire As Boolean
  
  If ((Button <> 1) And (Button <> 2)) Or devPrinter Then Exit Sub
  
  RefreshNow = False
  RefreshRequire = False
  With cboPreviewScale
    If Button = 1 Then
      If .ListIndex < .ListCount - 1 Then
        .ListIndex = .ListIndex + 1
        RefreshRequire = True
      End If
    Else
      If .ListIndex > 0 Then
        .ListIndex = .ListIndex - 1
        RefreshRequire = True
      End If
    End If
  End With
  RefreshNow = True
  
  If RefreshRequire Then
    RefreshPaper X / picPreview.ScaleWidth, Y / picPreview.ScaleHeight
  End If
End Sub

Private Sub RefreshPaper(ByVal XScale As Single, ByVal YScale As Single)
  Const BW As Long = 6
  
  Dim Value As Single
  Dim W As Single
  Dim H As Single
  Dim WW As Single
  Dim HH As Single
  
  If Not RefreshNow Then Exit Sub
  
  SetMP 11
  
  W = 0
  H = 0
  Select Case gPaperSize          '1 英寸 = 25.4 毫米
    Case vbPRPSLetter             '1 信笺， 8 1/2 x 11 英寸
      W = 25.4 * 8.5
      H = 25.4 * 11
    Case vbPRPSLetterSmall        '2 +A611 小型信笺， 8 1/2 x 11 英寸
      W = 25.4 * 8.5
      H = 25.4 * 11
    Case vbPRPSTabloid            '3 小型报， 11 x 17 英寸
      W = 25.4 * 11
      H = 25.4 * 17
    Case vbPRPSLedger             '4 分类帐， 17 x 11 英寸
      W = 25.4 * 17
      H = 25.4 * 11
    Case vbPRPSLegal              '5 法律文件， 8 1/2 x 14 英寸
      W = 25.4 * 8.5
      H = 25.4 * 14
    Case vbPRPSStatement          '6 声明书，5 1/2 x 8 1/2 英寸
      W = 25.4 * 5.5
      H = 25.4 * 8.5
    Case vbPRPSExecutive          '7 行政文件，7 1/2 x 10 1/2 英寸
      W = 25.4 * 7.5
      H = 25.4 * 10.5
    Case vbPRPSA3                 '8 A3, 297 x 420 毫米
      W = 297
      H = 420
    Case vbPRPSA4                 '9 A4, 210 x 297 毫米
      W = 210
      H = 297
    Case vbPRPSA4Small            '10  A4小号， 210 x 297 毫米
      W = 210
      H = 297
    Case vbPRPSA5                 '11  A5, 148 x 210 毫米
      W = 148
      H = 210
    Case vbPRPSB4                 '12  B4, 250 x 354 毫米
      W = 250
      H = 354
    Case vbPRPSB5                 '13  B5, 182 x 257 毫米
      W = 182
      H = 257
    Case vbPRPSFolio              '14  对开本， 8 1/2 x 13 英寸
      W = 25.4 * 8.5
      H = 25.4 * 13
    Case vbPRPSQuarto             '15  四开本， 215 x 275 毫米
      W = 215
      H = 275
    Case vbPRPS10x14              '16  10 x 14 英寸
      W = 25.4 * 10
      H = 25.4 * 14
    Case vbPRPS11x17              '17  11 x 17 英寸
      W = 25.4 * 11
      H = 25.4 * 17
    Case vbPRPSNote               '18  便条，8 1/2 x 11 英寸
      W = 25.4 * 8.5
      H = 25.4 * 11
    Case vbPRPSEnv9               '19  #9 信封， 3 7/8 x 8 7/8 英寸
      W = 25.4 * 3.875
      H = 25.4 * 8.875
    Case vbPRPSEnv10              '20  #10 信封， 4 1/8 x 9 1/2 英寸
      W = 25.4 * 4.125
      H = 25.4 * 9.5
    Case vbPRPSEnv11              '21  #11 信封， 4 1/2 x 10 3/8 英寸
      W = 25.4 * 4.5
      H = 25.4 * 10.375
    Case vbPRPSEnv12              '22  #12 信封， 4 1/2 x 11 英寸
      W = 25.4 * 4.5
      H = 25.4 * 11
    Case vbPRPSEnv14              '23  #14 信封， 5 x 11 1/2 英寸
      W = 25.4 * 5
      H = 25.4 * 11.5
    Case vbPRPSCSheet             '24  C 尺寸工作单
    Case vbPRPSDSheet             '25  D 尺寸工作单
    Case vbPRPSESheet             '26  E 尺寸工作单
    Case vbPRPSEnvDL              '27  DL 型信封， 110 x 220 毫米
      W = 110
      H = 220
    Case vbPRPSEnvC5              '28  C5 型信封， 162 x 229 毫米
      W = 162
      H = 229
    Case vbPRPSEnvC3              '29  C3 型信封， 324 x 458 毫米
      W = 324
      H = 458
    Case vbPRPSEnvC4              '30  C4 型信封， 229 x 324 毫米
      W = 229
      H = 324
    Case vbPRPSEnvC6              '31  C6 型信封， 114 x 162 毫米
      W = 114
      H = 162
    Case vbPRPSEnvC65             '32  C65 型信封，114 x 229 毫米
      W = 114
      H = 229
    Case vbPRPSEnvB4              '33  B4 型信封， 250 x 353 毫米
      W = 250
      H = 353
    Case vbPRPSEnvB5              '34  B5 型信封，176 x 250 毫米
      W = 176
      H = 250
    Case vbPRPSEnvB6              '35  B6 型信封， 176 x 125 毫米
      W = 176
      H = 125
    Case vbPRPSEnvItaly           '36  信封， 110 x 230 毫米
      W = 110
      H = 230
    Case vbPRPSEnvMonarch         '37  信封大王， 3 7/8 x 7 1/2 英寸
      W = 25.4 * 3.875
      H = 25.4 * 7.5
    Case vbPRPSEnvPersonal        '38  信封， 3 5/8 x 6 1/2 英寸
      W = 25.4 * 3.625
      H = 25.4 * 6.5
    Case vbPRPSFanfoldUS          '39  U.S. 标准复写簿， 14 7/8 x 11 英寸
      W = 25.4 * 14.875
      H = 25.4 * 11
    Case vbPRPSFanfoldStdGerman   '40  德国标准复写簿， 8 1/2 x 12 英寸
      W = 25.4 * 8.5
      H = 25.4 * 12
    Case vbPRPSFanfoldLglGerman   '41  德国法律复写簿， 8 1/2 x 13 英寸
      W = 25.4 * 8.5
      H = 25.4 * 13
    Case vbPRPSUser               '256 用户定义
      W = gWidth
      H = gHeight
    Case Else
    
  End Select
  If W > 0 Then
    If gOrientation = vbPRORLandscape Then  '横向:swap
      Value = W
      W = H
      H = Value
    End If
  Else
    With Printer
      .ScaleMode = vbMillimeters
      W = .ScaleWidth
      H = .ScaleHeight
    End With
  End If
  
  With picPreview
    WW = RoundTo15(W * 60.6 * sqrPreviewScale) + 15 * BW
    HH = RoundTo15(H * 60.6 * sqrPreviewScale) + 15 * BW
    .Move .Left, .Top, WW, HH
    .ScaleWidth = (W / sqrPrintScale) / ((WW - 15 * BW - 15) / WW)
    .ScaleHeight = (H / sqrPrintScale) / ((HH - 15 * BW - 15) / HH)
    .Cls
  End With
  
  picBoard_Resize
  
  Value = BorderSpace
  RefreshNow = False
  With hsrPreview
    If .Visible Then
      XScale = (picPreview.Width * XScale + Value - picBoard.Width / 2) / TwipsMove
      If XScale < 0 Then
        .Value = 0
      ElseIf XScale < .Max Then
        .Value = XScale
      Else
        .Value = .Max
      End If
    End If
  End With
  With vsrPreview
    If .Visible Then
      YScale = (picPreview.Height * YScale + Value - picBoard.Height / 2) / TwipsMove
      If YScale < 0 Then
        .Value = 0
      ElseIf YScale < .Max Then
        .Value = YScale
      Else
        .Value = .Max
      End If
    End If
  End With
  RefreshNow = True
  
  ViewMove
  
  PrintPage cboPage.ListIndex + 1
  
  With picPreview
    .ScaleMode = vbPixels
    W = .ScaleWidth
    H = .ScaleHeight
    .DrawWidth = 1
    .DrawStyle = vbSolid
    .FillStyle = vbFSSolid
    picPreview.Line (W - BW, -1)-Step(BW, BW + 2), &H808080, BF
    picPreview.Line (W - BW, BW)-(W, H), 0, BF
    picPreview.Line (-1, H - BW)-Step(BW + 2, BW), &H808080, BF
    picPreview.Line (BW, H - BW)-(W, H), 0, BF
  End With
  
  SetMP 0
End Sub

Private Sub vsrPreview_Change()
  ViewMove
End Sub

Private Sub ViewMove()
  Dim L As Long
  Dim T As Long
  
  If RefreshNow Then
    L = RoundTo15((picBoard.Width - picPreview.Width - IIf(vsrPreview.Visible, 270, 0)) / 2)
    T = RoundTo15((picBoard.Height - picPreview.Height - IIf(hsrPreview.Visible, 270, 0)) / 2)
    If L < BorderSpace Then
      L = BorderSpace
    End If
    If T < BorderSpace Then
      T = BorderSpace
    End If
    picPreview.Move L - hsrPreview * TwipsMove, T - vsrPreview * TwipsMove
  End If