prncls.cls

小型酒店管理系统源代码(采用access数据库)

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PrnCls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Dim P_TOPSPACE, P_BOTTOMSPACE, P_LEFTSPACE, P_RIGHTSPACE
' 可打印范围
Dim P_Fix   '表格偏差
Dim Pw, Ph
Dim PrinterFlag As Boolean
Dim ObjPrint As Object
Dim DC
Dim zm 'preivew zoom ratio


Public Sub NewLine()
  ObjPrint.CurrentY = ObjPrint.CurrentY + TextHeight("AA")
  ObjPrint.CurrentX = P_LEFTSPACE
End Sub
Public Sub NewLineBG(TSpace As Single)
  ObjPrint.CurrentY = ObjPrint.CurrentY + TextHeight("AA") + P_Fix + TSpace
  ObjPrint.CurrentX = P_LEFTSPACE
End Sub
Public Sub CenterPrn(LeftArea)
  With ObjPrint
  If CDbl(LeftArea) > 0 Then
    LeftArea = CDbl(LeftArea)
    If .ScaleWidth - LeftArea > 0 Then
      P_LEFTSPACE = (.ScaleWidth - LeftArea) / 2
    Else
      P_LEFTSPACE = 0
    End If
    P_RIGHTSPACE = P_LEFTSPACE
'    P_TOPSPACE = P_TOPSPACE * sc
'    P_BOTTOMSPACE = P_BOTTOMSPACE * sc
  Else
'    P_TOPSPACE = 50 * sc
'    P_BOTTOMSPACE = 50 * sc
    P_LEFTSPACE = 50
    P_RIGHTSPACE = 50
  End If
  .CurrentX = P_LEFTSPACE
  .CurrentY = P_TOPSPACE
  End With
End Sub


Sub PrintSetPsize(PStr As String, X As Single, y As Single)
    Select Case UCase(PStr)
        Case "A4"
            Pw = 11907
            Ph = 16832
        Case "A5"
            Pw = 8392
            Ph = 11907
        Case Else
            Pw = X
            Ph = y
    End Select
End Sub
Private Sub PrintInit(objtoprinton As Object)
    Dim psm
    Set ObjPrint = objtoprinton
    If TypeOf objtoprinton Is Printer Then
        PrinterFlag = True
    Else
        P_Fix = 10
        PrinterFlag = False
        CenterPrn ObjPrint.ScaleWidth
        P_TOPSPACE = 50
        P_BOTTOMSPACE = 50
        On Error GoTo NoPrinter
        psm = Printer.ScaleMode
        Printer.ScaleMode = 1
        ObjPrint.PaperWidth = Printer.Width
        ObjPrint.PaperHeight = Printer.Height
        ObjPrint.ScaleHeight = Printer.ScaleHeight
        ObjPrint.ScaleWidth = Printer.ScaleWidth
        ObjPrint.ScaleMode = psm
        GoTo A1
NoPrinter:
        If Pw = 0 Or Ph = 0 Then
            Pw = 11907
            Ph = 16832
        End If
        ObjPrint.PaperWidth = Pw
        ObjPrint.PaperHeight = Ph
        ObjPrint.ScaleWidth = Pw
        ObjPrint.ScaleHeight = Ph
A1:
    End If
End Sub
Sub PrintStartDoc(ObjPrn As Object, zmratio)
    zm = zmratio
    PrintInit ObjPrn
    If PrinterFlag Then
        Printer.Print ""
    Else
        ObjPrint.Cls
        ObjPrint.StartDoc zm, Pw, Ph
    End If
End Sub
Sub PrintSet(X As Single, y As Single, color)
    If PrinterFlag Then
        Printer.PSet (X, y), color
    Else
        ObjPrint.PsetA X, y, color
    End If
End Sub
Function TextWidth(str As String) As Single
    TextWidth = ObjPrint.TextWidth(str)
End Function
Function TextHeight(str As String) As Single
    TextHeight = ObjPrint.TextHeight(str)
End Function
Sub PrintPrint(PrintVar As String)
    If PrinterFlag Then
        Printer.Print PrintVar;
    Else
        ObjPrint.PrintA PrintVar
    End If
End Sub
Sub PrintLine(bLeft0, bTop0, bLeft1, bTop1)
    If PrinterFlag Then
        Printer.Line (bLeft0, bTop0)-(bLeft1, bTop1) '(bLeft0 - LRGap, bTop0 - TBGap)-(bLeft1 - LRGap, bTop1 - TBGap)
    Else
        ObjPrint.LineA bLeft0, bTop0, bLeft1, bTop1
    End If
End Sub
Sub PrintBox(bLeft, bTop, bLeft1, bTop1)
    If PrinterFlag Then
        Printer.Line (bLeft, bTop)-(bLeft1, bTop1), , B '(bLeft - LRGap, bTop - TBGap)-(bLeft1 - LRGap, bTop1 - TBGap), , B
    Else
        ObjPrint.BoxA bLeft, bTop, bLeft1, bTop1
    End If
End Sub
Sub PrintFilledBox(bLeft, bTop, bLeft1, bTop1, color)
    If PrinterFlag Then
        Printer.Line (bLeft, bTop)-(bLeft1, bTop1), color, BF '(bLeft - LRGap, bTop - TBGap)-(bLeft1 - LRGap, bTop1 - TBGap), color, BF
    Else
        ObjPrint.BoxF bLeft, bTop, bLeft1, bTop1, color
    End If
End Sub
Sub PrintCircle(bLeft, bTop, bRadius)
    If PrinterFlag Then
        Printer.Circle (bLeft, bTop), bRadius '(bLeft - LRGap, bTop - TBGap), bRadius
    Else
        ObjPrint.CircleA bLeft, bTop, bRadius
    End If
End Sub
Sub NewPage()
    If PrinterFlag Then
        Printer.NewPage
    Else
        ObjPrint.Cls
    End If
End Sub
Sub PrintPicture(pic As PictureBox, pLeft, pTop, pWidth, pHeight)
    ObjPrint.PaintPicture pic, pLeft, pTop, pWidth, pHeight
End Sub
Sub EndDoc()
    If PrinterFlag Then
        Printer.EndDoc
    End If
End Sub
Public Property Get CurrentX() As Single
    CurrentX = ObjPrint.CurrentX
End Property
Public Property Let CurrentX(ByVal New_V As Single)
    ObjPrint.CurrentX = New_V
End Property
Public Property Get CurrentY() As Single
    CurrentY = ObjPrint.CurrentY
End Property
Public Property Let CurrentY(ByVal New_V As Single)
    ObjPrint.CurrentY = New_V
End Property
Public Property Get BackColor() As OLE_COLOR
    BackColor = ObjPrint.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
    ObjPrint.BackColor = New_BackColor
End Property
Public Property Get ForeColor() As OLE_COLOR
    ForeColor = ObjPrint.ForeColor
End Property
Public Property Let ForeColor(ByVal New_BackColor As OLE_COLOR)
    ObjPrint.ForeColor = New_BackColor
End Property
Public Property Get Font() As Font
    Set Font = ObjPrint.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
    Set ObjPrint.Font = New_Font
End Property
Public Property Let FontName(pFontName)
    ObjPrint.FontName = pFontName
End Property
Public Property Get FontSize()
    If PrinterFlag Then
      FontSize = ObjPrint.FontSize
    Else
      FontSize = ObjPrint.FontSize / zm
    End If
End Property
Public Property Let FontSize(psize)
    If PrinterFlag Then
      ObjPrint.FontSize = psize
    Else
      ObjPrint.FontSize = psize * zm
    End If
End Property
Public Property Get FontBold() As Boolean
    FontBold = ObjPrint.FontBold
End Property
Public Property Let FontBold(psize As Boolean)
    ObjPrint.FontBold = psize
End Property
Public Property Get FontItalic() As Boolean
    FontItalic = ObjPrint.FontItalic
End Property
Public Property Let FontItalic(psize As Boolean)
    ObjPrint.FontItalic = psize
End Property
Public Property Get DrawWidth()
    DrawWidth = ObjPrint.DrawWidth
End Property
Public Property Let DrawWidth(psize)
    ObjPrint.DrawWidth = psize
End Property

Public Property Get DrawStyle() As Integer
    
    DrawStyle = DC.DrawStyle
End Property

Public Property Let DrawStyle(ByVal New_DrawStyle As Integer)
    DC.DrawStyle() = New_DrawStyle
'    PropertyChanged "DrawStyle"
End Property

Public Property Get DrawMode() As Integer
    DrawMode = ObjPrint.DrawMode
End Property

Public Property Let DrawMode(ByVal New_DrawMode As Integer)
    ObjPrint.DrawMode = New_DrawMode
End Property
Public Property Get FontStrikethru() As Boolean
    FontStrikethru = ObjPrint.FontStrikethru
End Property

Public Property Let FontStrikethru(ByVal New_FontStrikethru As Boolean)
    ObjPrint.FontStrikethru = New_FontStrikethru
End Property
Public Property Get FontUnderline() As Boolean
    FontUnderline = ObjPrint.FontUnderline
End Property
Public Property Let FontUnderline(ByVal New_FontUnderline As Boolean)
    ObjPrint.FontUnderline = New_FontUnderline
End Property
Public Property Get PaperHeight() As Single
    PaperHeight = ObjPrint.ScaleHeight
End Property
Public Property Get PaperWidth() As Single
    PaperWidth = ObjPrint.ScaleWidth
End Property

Sub BoxOut(str1 As String, len1, A1, TSpace, Bord)
  Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
  Dim OLDW
  With ObjPrint
  x1 = .CurrentX
  y1 = .CurrentY
  x2 = .CurrentX + len1 + P_Fix
  y2 = .CurrentY + .TextHeight("XX的") + TSpace + P_Fix
  OLDW = .DrawWidth
  If Val(MID(Bord, 1, 1)) > 0 Then
    .DrawWidth = Val(MID(Bord, 1, 1))
    PrintLine x1, y1, x1, y2
  End If
  If Val(MID(Bord, 2, 1)) > 0 Then
    .DrawWidth = Val(MID(Bord, 2, 1))
     PrintLine x1, y1, x2, y1
  End If
  If Val(MID(Bord, 3, 1)) > 0 Then
    .DrawWidth = Val(MID(Bord, 3, 1))
     PrintLine x2, y1, x2, y2
  End If
  If Val(MID(Bord, 4, 1)) > 0 Then
    .DrawWidth = Val(MID(Bord, 4, 1))
    PrintLine x1, y2, x2, y2
  End If
  .DrawWidth = OLDW
  .CurrentX = x1 + P_Fix
  .CurrentY = y1
  Do While len1 > 0 And .TextWidth(str1) > len1
    str1 = left(str1, Len(str1) - 1)
  Loop
  If UCase(A1) = "R" Then
    .CurrentX = x1 + len1 - .TextWidth(str1)
  Else
    If UCase(A1) = "C" Then
      .CurrentX = x1 + (len1 - .TextWidth(str1)) / 2
    End If
  End If
  .CurrentY = .CurrentY + (P_Fix + TSpace) / 2
  PrintPrint str1
  .CurrentY = y1
  .CurrentX = x2
  End With
End Sub

Sub BoxOutA(str1 As String, len1, A1, TSpace)
  Dim x1 As Single, y1 As Single, x2 As Single, y2 As Single
  Dim OLDW
  With ObjPrint
  x1 = .CurrentX
  y1 = .CurrentY
  x2 = .CurrentX + len1 + P_Fix
  y2 = .CurrentY + .TextHeight("XX的") + TSpace + P_Fix
  OLDW = .DrawWidth
  .DrawWidth = 1
  PrintBox x1, y1, x2, y2
  .DrawWidth = OLDW
  .CurrentY = y1
  .CurrentX = x1 + P_Fix
  Do While len1 > 0 And .TextWidth(str1) > len1
    str1 = left(str1, Len(str1) - 1)
  Loop
  If A1 = "R" Or A1 = "r" Then
    .CurrentX = x1 + len1 - .TextWidth(str1)
  Else
    If A1 = "C" Or A1 = "c" Then
      .CurrentX = x1 + (len1 - .TextWidth(str1)) / 2
    End If
  End If
  .CurrentY = .CurrentY + (P_Fix + TSpace) / 2
  PrintPrint str1
  .CurrentY = y1
  .CurrentX = x2
  End With
End Sub