frmpreview.frm

星级酒店管理系统（附带系统自写控件源码）

        Command3.Visible = True
       Else
        Command3.Visible = False
      End If
  Else
   VScroll1.Visible = False
   HScroll1.Visible = False
   Command3.Visible = False
  End If
SelectFile.MousePointer = 0
End If
Exit Sub

NOp:
  MsgBox "图片出错，不能浏览！", vbOKOnly + 16, "图片不能安装"
  DisplayPicture.Picture = LoadPicture()
  SelectFile.MousePointer = 0
  Exit Sub

End Sub

Private Sub Check2_Click()
   
   On Error Resume Next
   
If Check1.Value = 1 Then
   If Check2.Value = 1 Then
     DisplayPicture.Stretch = False
     HScroll1.Value = 0
     VScroll1.Value = 0
     HScroll1.Max = DisplayPicture.Width - Picture1.Width + 280
     VScroll1.Max = DisplayPicture.Height - Picture1.Height + 280
     VScroll1.Visible = Picture1.Height < DisplayPicture.Height
     HScroll1.Visible = Picture1.Width < DisplayPicture.Width
        If HScroll1.Visible Or VScroll1.Visible Then
           Command3.Visible = True
         Else
           Command3.Visible = False
        End If
      Else
     DisplayPicture.Height = 3645
     DisplayPicture.Width = 2925
     DisplayPicture.Stretch = True
     DisplayPicture.Move 0, 0
     VScroll1.Visible = False
     HScroll1.Visible = False
     Command3.Visible = False
  End If
End If
End Sub

Private Sub Command1_Click()

On Error Resume Next

ConfigForm.CC(5).Text = Text1.Text
Unload Me

End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub cmbSize_Change()

On Error Resume Next

    ResizePic
   '写到图片中

End Sub

Private Sub cmbSize_Click()

On Error Resume Next

    ResizePic
   '写到图片中
   
End Sub

Private Sub cmdCancel_Click()

 Unload Me
 
End Sub

Private Sub cmdDown_Click()

 '显示上页
  curPage = curPage + 1
  picPrint.Cls
  PrintPreview GetSiteID(sPubSite)
  
End Sub

Private Sub cmdPrint_Click()
 
  frmCash.PrintSheet GetSiteID(sPubSite)
 
End Sub

Private Sub cmdUp_Click()

 '显示上页
  curPage = curPage - 1
  picPrint.Cls
  PrintPreview GetSiteID(sPubSite)

End Sub

Private Sub Command3_Click()

   On Error Resume Next
   If HScroll1.Value < HScroll1.Max - 100 Then
      HScroll1.Value = HScroll1.Value + 100
   End If
   If VScroll1.Value < VScroll1.Max - 100 Then
      VScroll1.Value = VScroll1.Value + 100
   End If

End Sub

Private Sub DelFile_Click()

On Error Resume Next
Dim DelOk As Integer
    DelOk = MsgBox("真的要删除文件：(Y/N) " & Chr(10) & Chr(13) & Text1.Text, vbYesNo + 16, "删除文件")
    If DelOk = 6 Then
       On Error GoTo KillErr
       Kill Text1.Text
       Text1.Text = ""
       If Check1.Value = 1 Then
          DisplayPicture.Picture = LoadPicture()
       End If
       File1.Refresh
      Else
       Exit Sub
    End If
Exit Sub
KillErr:
  MsgBox "删除文件错误，文件被打开或共享", vbOKOnly + 16, "警告"
  Exit Sub
End Sub

Private Sub Dir1_Change()

On Error Resume Next
File1.Path = Dir1.Path
Select Case SelectType.Text
  Case "位图文件|*.BMP"
       File1.Pattern = "*.bmp"
  Case "压缩文件|*.JPG"
       File1.Pattern = "*.jpg"
  Case "GIF文件|*.GIF"
       File1.Pattern = "*.gif"
  Case "图标文件|*.ICO"
       File1.Pattern = "*.ico"
  Case "WMF|*.WMF"
       File1.Pattern = "*.wmf"
  Case "EMF|*.EMF"
       File1.Pattern = "*.emf"
  Case "RLE|*.RLE"
       File1.Pattern = "*.rle"
End Select
Text1.Text = ""
End Sub

Private Sub DisplayPicture_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
 
On Error Resume Next
  
   LB = True
   Sx = x
   Sy = y
   DisplayPicture.MouseIcon = picDown.Picture
   
End Sub

Private Sub DisplayPicture_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

On Error Resume Next

If HScroll1.Visible = True Or VScroll1.Visible = True Then
If LB = True Then
  Mx = x
  My = y
  If HScroll1.Value - (Mx - Sx) / 50 <= HScroll1.Max And HScroll1.Value - (Mx - Sx) / 50 > 0 Then
     HScroll1.Value = HScroll1.Value - (Mx - Sx) / 50
  End If
  If VScroll1.Value - (My - Sy) / 50 <= VScroll1.Max And VScroll1.Value - (My - Sy) / 50 > 0 Then
     VScroll1.Value = VScroll1.Value - (My - Sy) / 50
  End If
End If
End If

End Sub

Private Sub DisplayPicture_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  
On Error Resume Next

  LB = False
  DisplayPicture.MouseIcon = picUP.Picture
  
End Sub

Private Sub Drive1_Change()
On Error GoTo Noread
Dir1.Path = Drive1.Drive
Text1.Text = ""
Exit Sub
Noread:
  Dim Okread As Integer
   Okread = MsgBox("" & Drive1.Drive & " 驱动器没有准备好！", vbRetryCancel + 16, "驱动器没有准备好！")
  If Okread = 4 Then
    Call Drive1_Change
  Else
   Drive1.Drive = Dir1.Path
   Text1.Text = ""
  End If
End Sub

Private Sub File1_Click()

On Error Resume Next
Dim DirStr As String
DirStr = Dir1.Path
If Right(DirStr, 1) <> "\" Then
   DirStr = DirStr + "\"
End If
  DirStr = DirStr + File1.FileName
  Text1.Text = DirStr
If Check1.Value = 1 Then
  On Error GoTo PictureErr
  SelectFile.MousePointer = 11
  If Check2.Value = 1 Then
     DisplayPicture.Stretch = False
      Else
     DisplayPicture.Height = 3645
     DisplayPicture.Width = 2925
     DisplayPicture.Stretch = True
  End If
  DisplayPicture.Picture = LoadPicture(Text1.Text)
  'Large photo display
  If Check2.Value = 1 Then
  HScroll1.Value = 0
  VScroll1.Value = 0
  HScroll1.Max = DisplayPicture.Width - Picture1.Width + 280
  VScroll1.Max = DisplayPicture.Height - Picture1.Height + 280
  VScroll1.Visible = Picture1.Height < DisplayPicture.Height
  HScroll1.Visible = Picture1.Width < DisplayPicture.Width
   If HScroll1.Visible Or VScroll1.Visible Then
     Command3.Visible = True
      Else
     Command3.Visible = False
   End If
   Else
   VScroll1.Visible = False
   HScroll1.Visible = False
   Command3.Visible = False
  End If
End If
  SelectFile.MousePointer = 0
  Exit Sub
PictureErr:
  MsgBox "图片出错，不能浏览！", vbOKOnly + 16, "图片不能安装"
  DisplayPicture.Picture = LoadPicture()
  SelectFile.MousePointer = 0
  Exit Sub
End Sub

Private Sub File1_DblClick()

On Error Resume Next
Call Command1_Click
End Sub

Private Sub File1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

On Error Resume Next
If Button = 2 Then
   If File1.ListIndex >= 0 Then
      DelFile.Enabled = True
         Else
           DelFile.Enabled = False
             End If
      PopupMenu MenuEdit
End If
End Sub

Private Sub Form_Load()

On Error GoTo PrintErr

GetFormSet Me, Screen

picPrint.ScaleMode = 6     '厘米模式
picPrint.Width = 7000      '宽11CM
picPrint.Height = 14000    '高21cm
cmbSize.Text = "100%"
Picture1.Left = 150

curConsumeAmo = 0
'给出消费金额
GetConsum "", "", frmCash.cmbDZ.Text

'当前第一页,与总页数
curPage = 1
curPages = 1

'显示预览
picPrint.Cls
PrintPreview GetSiteID(sPubSite)

DisplayPicture.MousePointer = 99
DisplayPicture.MouseIcon = picUP.Picture
HScroll1.Visible = False

Exit Sub
PrintErr:
MsgBox "显示打印预览错误:" & Err.Description & vbCrLf & "请直接使用预览窗口的打印功能,打印帐单。", vbCritical

End Sub

'更新消费金额
Private Sub GetConsum(sType As String, sMID As String, curRate As Integer)

    On Error GoTo Err_DC
    
    Dim hDB As Connection
    Dim hEf As Recordset
    Dim tmpEF As Recordset
    Dim sTMp As String
    Dim cDCJE As Currency, cDCJGF        '点菜金额
    Dim JSAmo As Currency, JGAmo As Currency, SFAmo As Currency, FKAmo As Currency
    Me.MousePointer = 11
    
   '更新座位号消费单
    Set hDB = CreateObject("ADODB.Connection")
        hDB.Open Constr
    Set hEf = CreateObject("ADODB.Recordset")
        hEf.Open "Select tmpsite.SFAmo,tmpsite.DCJE,tmpsite.RJCJE,tmpsite.LJCJE,tmpsite.JSJE," _
            & "tmpsite.JSJGF,tmpsite.LJCJGF,tmpsite.DCJGF,tmpsite.Discount," _
            & "tmpsite.BXF,tmpsite.JEAMO,SiteType.Class,SiteType.Price,Sitetype.SupperPrice,SiteType.NightPrice " _
            & " From tmpSite Inner Join SiteType On tmpsite.Site=SiteType.Class " _
            & " Where tmpsite.Site='" & sPubSite & "'", hDB, adOpenStatic, adLockOptimistic, adCmdText
     
     If hEf.BOF And hEf.EOF Then '没有该记录时
        hEf.Close
        Set hEf = Nothing
        hDB.Close
        Set hDB = Nothing
        Me.MousePointer = 0
        cJE = 0: cBXF = 0: cRate = 0
        JSAmo = 0: JGAmo = 0: SFAmo = 0: FKAmo = 0
        curConsumeAmo = 0
        MsgBox "没有消费记录,不能汇总消费金额？  " & vbCrLf _
            & "或者其他操作已经结帐。    ", vbInformation
        Exit Sub
      Else
       '1/给出客户的打折率
        'If sMID = "" Then
         cDiscount = CInt(frmCash.cmbDZ.Text)
        '  Else
           '给出该客户的打折率
        '   cDiscount = GetCustomerRate(sMID)
        'End If
       '2/给出tmpCust的100不打折的金额,应收等于实付,CDiscount=100,加工费不打折
       'A/更新打折内容。
        sTMp = "Update tmpCust Set YFAmo=Amo*" & (cDiscount) / 100 & " Where Site='" & sPubSite & "' And DType In(Select Class from MenuType Where Discount=1)"
        hDB.Execute sTMp
       'B/更新不打折内容
        sTMp = "Update tmpCust Set YFAmo=Amo Where Site='" & sPubSite & "' And DType In(Select Class from MenuType Where Discount=0)"
        hDB.Execute sTMp
       '3/计算金额,不论菜单类型,汇总XX座位的消费金额 ------------------------------------------------------
        sTMp = "Select Sum(YFAmo),Sum(JGF) From TmpCust Where Site='" & sPubSite & "'"
        Set tmpEF = CreateObject("ADODB.Recordset")
            tmpEF.Open sTMp, hDB, adOpenStatic, adLockOptimistic, adCmdText
            If tmpEF.BOF And tmpEF.EOF Then
                cDCJE = 0: cDCJGF = 0
              Else
                cDCJE = tmpEF.Fields(0)   '应付
                cDCJGF = tmpEF.Fields(1)  '点菜加工费
            End If
            tmpEF.Close
            Set tmpEF = Nothing
        '-------------------------------------------------------------------------------------------------
        '4/更新当前座位的消费金额。
            Dim tmplHour As Integer
               tmplHour = Hour(Time)
            If tmplHour >= Lunch1 And tmplHour < Lunch2 Then   '中午
               cBXF = hEf("Price")
              ElseIf tmplHour >= Supper1 And tmplHour < Supper2 Then   '下午
               cBXF = hEf("SupperPrice")
              ElseIf tmplHour >= Night1 And tmplHour < NIght2 Then     '晚上
               cBXF = hEf("NightPrice")
              Else
               cBXF = hEf("Price")
            End If
            hEf.Fields("BXF") = cBXF    '包厢费
            hEf.Fields("DCJE") = cDCJE           '点菜金额,已经打折的菜单
            hEf.Fields("DCJGF") = cDCJGF         '加工费
            hEf.Fields("Discount") = cDiscount
            JSAmo = cDCJE      '点菜金额
            JGAmo = cDCJGF     '加工费
            
          '给出金额,界面显示
            cJE = cDCJE + cDCJGF + hEf("Price")
           '金额=消费金额（加工费不打折）+包厢费+DCJGF
            hEf.Fields("JEAmo") = Round((hEf.Fields("DCJE") + hEf.Fields("BXF") + hEf.Fields("DCJGF")), 0)
            'hEf.Fields("SfAmo") = hEf.Fields("JeAmo")  '实付金额
            hEf.Update
     End If
     curConsumeAmo = JSAmo + JGAmo

    '5/显示
      hEf.Close
      Set hEf = Nothing
      hDB.Close
      Set hDB = Nothing
      Me.MousePointer = 0