preview.ctl

自定报表组件

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.UserControl Preview 
   AutoRedraw      =   -1  'True
   CanGetFocus     =   0   'False
   ClientHeight    =   765
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   750
   ClipControls    =   0   'False
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   765
   ScaleWidth      =   750
   ToolboxBitmap   =   "Preview.ctx":0000
   Begin MSComDlg.CommonDialog cdlPrinter 
      Left            =   270
      Top             =   240
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Image imgPreview 
      Height          =   225
      Left            =   60
      Picture         =   "Preview.ctx":00FA
      Top             =   60
      Width           =   240
   End
End
Attribute VB_Name = "Preview"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Const ctlW As Long = 420
Private Const cVersion = "V1.6 May,14 1998"

Private Sub UserControl_Initialize()
  imgPreview.Move (ctlW - imgPreview.Width) / 2, (ctlW - imgPreview.Height) / 2
  UserControl.Line (0, 0)-(ctlW, ctlW), &HFFFFFF, B
  UserControl.Line (-15, -15)-(ctlW - 15, ctlW - 15), &H808080, B
  Size ctlW, ctlW
  gPaperSize = Printer.PaperSize
  gOrientation = Printer.Orientation
  gPreviewShow = True
  BarCodesOf39ExInit 0
End Sub

Private Sub UserControl_InitProperties()
  Caption = "打印预览"
  PaperSize = Val(Printer.PaperSize)
  Orientation = Val(Printer.Orientation)
  PrinterType = 0
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Caption = PropBag.ReadProperty("Caption", Extender.Name)
  NewDoc
End Sub

Private Sub UserControl_Resize()
  Size ctlW, ctlW
End Sub

Public Sub Preview()
  Dim W As Long
  Dim SS As Long
  On Error Resume Next
  W = Printer.ScaleWidth
  If Err > 0 Then
    cdlPrinter.Flags = cdlPDPrintSetup
    cdlPrinter.Action = 5
    Exit Sub
  End If
  If gPreviewPageCount = 0 Then
    MsgBox "没有所需要的打印数据，请查实！", 48
  Else
    SetMP 11
    frmPreview.Show vbModal
    SetMP 0
  End If
End Sub

Public Property Get Caption() As String
Attribute Caption.VB_ProcData.VB_Invoke_Property = ";外观"
Attribute Caption.VB_UserMemId = -518
Attribute Caption.VB_MemberFlags = "200"
  Caption = gPreviewCaption
End Property

Public Property Let Caption(ByVal vNewValue As String)
  gPreviewCaption = vNewValue
  
  PropertyChanged "Caption"
End Property

Private Sub UserControl_Terminate()
  Dim FN As String
  
  On Error Resume Next
  FN = App.Path
  If Right(FN, 1) <> "\" Then FN = FN & "\"
  FN = FN & "PIC*.TMP"
  FN = Dir(FN)
  Do While Len(FN)
    Kill FN
    FN = Dir
  Loop
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "Caption", gPreviewCaption, Extender.Name
  PropBag.WriteProperty "Orientation", gOrientation, Extender.Name
  PropBag.WriteProperty "PaperSize", gPaperSize, Extender.Name
End Sub

Public Property Get Version() As String
  Version = cVersion
End Property

Public Property Let Version(ByVal vNewValue As String)

End Property

Private Sub AddPreviewCMD(CMD As String, Optional ByVal V1, Optional ByVal V2, Optional ByVal V3, Optional ByVal V4, Optional ByVal Msg)
  Dim N As Long
  
  If gPreviewPageCount < 0 Then
    NewPage
  End If
  
  With arrPreviewCMD(gPreviewCMDCount)
    .CMD = CMD
    If Not IsMissing(V1) Then .V1 = V1
    If Not IsMissing(V2) Then .V2 = V2
    If Not IsMissing(V3) Then .V3 = V3
    If Not IsMissing(V4) Then .V4 = V4
    If Not IsMissing(Msg) Then .Msg = Msg
  End With
  
  gPreviewCMDCount = gPreviewCMDCount + 1
  N = UBound(arrPreviewCMD)
  If gPreviewCMDCount > N Then
    ReDim Preserve arrPreviewCMD(N + 100)
  End If
End Sub

Public Sub EndDoc()
  '结束文档
  NewPage
End Sub

Public Sub NewDoc(Optional ByVal Msg)
  '启动新文档
  'Msg:页标题
  ReDim arrPreviewCMD(0)
  gPreviewCMDCount = 0
  
  gPreviewPageCount = -1
  NewPage Msg
  
  Dim X As Printer
  For Each X In Printers
     If X.Port = Printer.Port Then
        Set Printer = X
        Exit For
     End If
  Next

  gPaperSize = Printer.PaperSize
  gOrientation = Printer.Orientation
  
End Sub

Public Sub NewPage(Optional ByVal Msg)
  '新打印页
  'Msg:页标题
  If IsMissing(Msg) Then Msg = ""
  
  gPreviewPageCount = gPreviewPageCount + 1
  ReDim Preserve arrPreviewPage(gPreviewPageCount)
  
  If gPreviewPageCount > 0 Then
    arrPreviewPage(gPreviewPageCount - 1).CMDEnd = gPreviewCMDCount - 1
  End If
  With arrPreviewPage(gPreviewPageCount)
    .Name = Msg
    .CMDStart = gPreviewCMDCount
    .CMDEnd = -1
  End With
  '初始化
  CellSize 1, 1
  ScaleLeft = 0
  ScaleTop = 0
  FontName = "宋体"
  FontSize = 9
  FontBold = False
  FontItalic = False
  FontStrikethru = False
  FontTransparent = True
  FontUnderline = False
  DrawMode = vbCopyPen
  DrawStyle = vbSolid
  DrawWidth = 1
  ForeColor = 0
  FillColor = 0
  FillStyle = vbFSTransparent
End Sub

Public Sub Arc(ByVal X As Single, ByVal Y As Single, ByVal Radius As Single, Optional ByVal StartDegree, Optional ByVal EndDegree, Optional ByVal Aspect)
  'Units:Cell Size
  Dim Msg As String
  
  If Not IsMissing(StartDegree) Then Msg = StartDegree
  Msg = Msg & ","
  If Not IsMissing(EndDegree) Then Msg = Msg & EndDegree
  Msg = Msg & ","
  If Not IsMissing(Aspect) Then Msg = Msg & Aspect
  
  AddPreviewCMD "Arc", X, Y, Radius, StartDegree, Msg
End Sub

Public Sub OutputBarCodeOf39Ex(ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single, ByVal BarCode As String)
  'Units:CellSize
  'Left,Top,Width,Height
  If gBarCodeType = 1 Then
    AddPreviewCMD "OutputBarCodeOf25", L, T, W, H, BarCode
  ElseIf gBarCodeType = 2 Then
    AddPreviewCMD "OutputBarCodeOf128", L, T, W, H, BarCode
  Else
    AddPreviewCMD "OutputBarCodeOf39Ex", L, T, W, H, BarCode
  End If
End Sub

Public Sub Box(ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single)
  'Units:CellSize
  'Left,Top,Width,Height
  AddPreviewCMD "Box", L, T, W, H
End Sub

Public Sub BoxLine(ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single)
  'Units:CellSize
  'Left,Top,Width,Height
  AddPreviewCMD "BoxLine", L, T, W, H
End Sub

Public Sub CellSize(ByVal W As Single, ByVal H As Single)
  'Units:mm
  'Width,Height
  AddPreviewCMD "CellSize", W, H
End Sub

Public Property Let DrawMode(ByVal vNewValue As Long)
  AddPreviewCMD "DrawMode", vNewValue
End Property

Public Property Let DrawStyle(ByVal vNewValue As Long)
  AddPreviewCMD "DrawStyle", vNewValue
End Property

Public Property Let DrawWidth(ByVal vNewValue As Long)
  AddPreviewCMD "DrawWidth", vNewValue
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
  AddPreviewCMD "FillColor", vNewValue
End Property

Public Property Let FillStyle(ByVal vNewValue As Long)
  AddPreviewCMD "FillStyle", vNewValue
End Property

Public Property Let FontBold(ByVal vNewValue As Boolean)
  AddPreviewCMD "FontBold", vNewValue
End Property

Public Property Let FontItalic(ByVal vNewValue As Boolean)
  AddPreviewCMD "FontItalic", vNewValue
End Property

Public Property Let FontName(ByVal vNewValue As String)
  If Len(vNewValue) > 0 Then AddPreviewCMD "FontName", , , , , vNewValue
End Property

Public Property Let FontSize(ByVal vNewValue As Single)
  AddPreviewCMD "FontSize", vNewValue
End Property

Public Property Let FontStrikethrough(ByVal vNewValue As Boolean)
  AddPreviewCMD "FontStrikethrough", vNewValue
End Property

Public Property Let FontTransparent(ByVal vNewValue As Boolean)
  AddPreviewCMD "FontTransparent", vNewValue
End Property

Public Property Let FontUnderline(ByVal vNewValue As Boolean)
  AddPreviewCMD "FontUnderline", vNewValue
End Property

Public Property Let ForeColor(ByVal vNewValue As Long)
  AddPreviewCMD "ForeColor", vNewValue
End Property

Public Sub ShowGrid()
  AddPreviewCMD "ShowGrid"
End Sub

Public Sub LineH(ByVal X As Single, ByVal Y As Single, ByVal W As Single)
  'Units:CellSize
  'X,Y:left point
  'Width
  AddPreviewCMD "LineH", X, Y, W
End Sub

Public Sub LineU(ByVal X As Single, ByVal Y As Single, ByVal W As Single)
  'Line UnderLine by Chinese word
  'Units:CellSize
  'X,Y:left point
  'Width
  AddPreviewCMD "LineU", X, Y, W
End Sub

Public Sub LineV(ByVal X As Single, ByVal Y As Single, ByVal H As Single)
  'Units:CellSize
  'X,Y:top point
  'Height
  AddPreviewCMD "LineV", X, Y, H
End Sub

Public Sub LineW(ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single)
  'Wild line
  'Units:CellSize
  'X1,Y1:start point
  'X2,Y2:end point
  AddPreviewCMD "LineW", X1, Y1, X2, Y2
End Sub

Public Sub PaintPicture(pic As Picture, ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single)
  'pic:picture
  'Units:CellSize
  'Left,Top,Width,Height
  Dim FN As String
  
  FN = App.Path
  If Right(FN, 1) <> "\" Then FN = FN & "\"
  FN = FN & "PIC" & Format(gPreviewCMDCount, "00000") & ".TMP"
  
  On Error Resume Next
  Kill FN
  SavePicture pic, FN
  
  AddPreviewCMD "PaintPicture", L, T, W, H, FN
End Sub

Public Property Let PaperSize(ByVal vNewValue As Long)
  If (vNewValue > 0) And (vNewValue <= 256) Then
    gPaperSize = vNewValue
  End If
End Property
Public Property Get PaperSize() As Long
  PaperSize = gPaperSize
End Property

Public Property Let Orientation(ByVal vNewValue As Long)
  If (vNewValue = 1) Or (vNewValue = 2) Then
    gOrientation = vNewValue
  End If
End Property
Public Property Get Orientation() As Long
  Orientation = gOrientation
End Property


Public Sub PointSet(ByVal X As Single, ByVal Y As Single, Optional ByVal Color)
  Dim Msg As String
  
  If Not IsMissing(Color) Then Msg = Color
  AddPreviewCMD "PointSet", X, Y, , , Msg
End Sub

Public Property Let ScaleLeft(ByVal vNewValue As Single)
  'Units:mm
  AddPreviewCMD "ScaleLeft", vNewValue
End Property

Public Property Let ScaleTop(ByVal vNewValue As Single)
  'Units:mm
  AddPreviewCMD "ScaleTop", vNewValue
End Property

Public Sub TextC(ByVal X As Single, ByVal Y As Single, ByVal Msg As String)
  'Alignment:center
  'Units:CellSize
  'X,Y:center point
  'Msg
  AddPreviewCMD "TextC", X, Y, , , Msg
End Sub

Public Sub TextE(ByVal X As Single, ByVal Y As Single, ByVal W As Single, ByVal Msg As String)
  'equal distance
  'Units:CellSize
  'X,Y:left center point
  'Width
  'Msg
  AddPreviewCMD "TextE", X, Y, W, , Msg
End Sub

Public Sub TextL(ByVal X As Single, ByVal Y As Single, ByVal Msg As String)
  'Alignment:Left
  'Units:CellSize
  'X,Y:Left center point
  'Msg
  AddPreviewCMD "TextL", X, Y, , , Msg
End Sub

Public Sub TextR(ByVal X As Single, ByVal Y As Single, ByVal Msg As String)
  'Alignment:Right
  'Units:CellSize
  'X,Y:right center point
  'Msg
  AddPreviewCMD "TextR", X, Y, , , Msg
End Sub

Public Sub TextVE(ByVal X As Single, ByVal Y As Single, ByVal H As Single, ByVal Msg As String)
  AddPreviewCMD "TextVE", X, Y, H, , Msg
End Sub

Public Property Let PreviewShow(ByVal vNewValue As Boolean)
  gPreviewShow = vNewValue
End Property

Public Property Get BackColor() As Variant
  
End Property

Public Property Let BackColor(ByVal vNewValue As Variant)
  AddPreviewCMD "BackColor", vNewValue
End Property

Public Property Let Width(ByVal vNewValue As Variant)
  AddPreviewCMD "ScaleWidth", vNewValue
  gWidth = vNewValue
End Property

Public Property Let Height(ByVal vNewValue As Variant)
  AddPreviewCMD "ScaleHeight", vNewValue
  gHeight = vNewValue
End Property
Public Property Let BarCodeType(ByVal vNewValue As Variant)
  AddPreviewCMD "BarCodeType", vNewValue
  gBarCodeType = vNewValue
End Property
Public Property Let PrinterType(ByVal vNewValue As Long)
  On Error Resume Next
  Set Printer = Printers(vNewValue)
  gPrinterType = vNewValue
End Property