frmsitesataus.frm

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

        mnuCheckOut.Enabled = False
        mnuChange.Enabled = False
        mnuViewBOOK.Enabled = False
        mnuCancelBook.Enabled = False
        mnuCopy.Enabled = False
        mnuMaintenans.Enabled = False
        mnuCancelMaintenans.Enabled = False
        mnuClean.Enabled = False
        MnuOpen.Enabled = False
        
   Select Case Left(optThumb(Index).Tag, 1)
        '预订操作........................................
         Case "1"
            mnuViewBOOK.Enabled = True
            mnuTable.Enabled = True
            mnuCancelBook.Enabled = True
            MnuOpen.Enabled = True
            mnuBookthis.Enabled = True
        '使用中...........................................
         Case "2"
            mnuBookthis.Enabled = True
            mnuInfo.Enabled = True
            mnuCheckOut.Enabled = True
            mnuChange.Enabled = True
            mnuCopy.Enabled = True
            mnuClean.Enabled = True
            mnuTable.Enabled = True
        '空闲...........................................空闲时，才能设置为维修状态.
         Case "0"
            mnuBookthis.Enabled = True
            mnuTable.Enabled = True
            mnuMaintenans.Enabled = True
            MnuOpen.Enabled = True
        '恢复维修的桌号为正常
         Case "4"
            mnuCancelMaintenans.Enabled = True
        '已经结帐，但是没有离桌时
         Case "3"
            mnuClean.Enabled = True
         Case Else
   End Select
  '给出座位ID
   sPubSite = GetBookID(optThumb(Index).Tag)
   
  '显示操作菜单
   PopupMenu mnuBook
   
End Sub

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

 '给出座位ID
  sPubSite = GetBookID(optThumb(Index).Tag)
  If Button = 2 Then
     '进行单击操作
      optThumb(Index).Value = True
  End If
  
End Sub

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

  If Button = 2 Then
        mnuBookthis.Enabled = False
        mnuTable.Enabled = False
        mnuInfo.Enabled = False
        mnuCheckOut.Enabled = False
        mnuChange.Enabled = False
        mnuViewBOOK.Enabled = False
        mnuCancelBook.Enabled = False
        mnuCopy.Enabled = False
        mnuMaintenans.Enabled = False
        mnuCancelMaintenans.Enabled = False
        mnuClean.Enabled = False
        MnuOpen.Enabled = False
        
   Select Case Left(optThumb(Index).Tag, 1)
        '预订操作........................................
         Case "1"
            mnuViewBOOK.Enabled = True
            mnuTable.Enabled = True
            mnuCancelBook.Enabled = True
            MnuOpen.Enabled = True
            mnuBookthis.Enabled = True
        '使用中...........................................
         Case "2"
            mnuBookthis.Enabled = True
            mnuInfo.Enabled = True
            mnuCheckOut.Enabled = True
            mnuChange.Enabled = True
            mnuCopy.Enabled = True
            mnuClean.Enabled = True
            mnuTable.Enabled = True
        '空闲...........................................空闲时，才能设置为维修状态.
         Case "0"
            mnuBookthis.Enabled = True
            mnuTable.Enabled = True
            mnuMaintenans.Enabled = True
            MnuOpen.Enabled = True
        '恢复维修的桌号为正常
         Case "4"
            mnuCancelMaintenans.Enabled = True
        '已经结帐，但是没有离桌时
         Case "3"
            mnuClean.Enabled = True
         Case Else
   End Select
      '给出座位ID
       sPubSite = GetBookID(optThumb(Index).Tag)
      '显示操作菜单
       PopupMenu mnuBook
  End If
  
End Sub

Private Sub vsbSlide_Change()

    On Error Resume Next
    picSlide.Top = -vsbSlide.Value
    picFrame.SetFocus
    
End Sub

Private Sub vsbSlide_Scroll()

    On Error Resume Next

    vsbSlide_Change

End Sub

Public Sub Browse()
   
   On Error GoTo GetERR
  
  '放置图片
   lCount = 0
   Dim DB As Connection, EF As Recordset, HH As Integer
   Set DB = CreateObject("ADODB.Connection")
       DB.Open Constr
   Set EF = CreateObject("ADODB.Recordset")
       EF.Open "Select Count(*) From SiteType" & sWhere, DB, adOpenStatic, adLockReadOnly, adCmdText
    
       If EF.EOF And EF.BOF Then  '没有产品时
          EF.Close
          DB.Close
          Set EF = Nothing
          Set DB = Nothing
         '打开图片
          CreateThumbs
          'MsgBox "没有找到有效座位(餐桌),请在基本配置中设置后继续？ ", vbInformation, "Design By Yusilong."
          Exit Sub
        Else
          lCount = EF.Fields(0)
          If lCount = 0 Then
              EF.Close
              DB.Close
              Set EF = Nothing
              Set DB = Nothing
              '打开图片
              CreateThumbs
              Exit Sub
            Else
              EF.Close
              DB.Close
              Set EF = Nothing
              Set DB = Nothing
             '打开图片
              CreateThumbs
          End If
       End If
  
  Exit Sub
GetERR:
  MsgBox "给出餐桌列表错误:" & Err.Description & vbCrLf & vbCrLf _
    & "请关闭浏览窗口,重新打开试试。   ", vbCritical
  Exit Sub
  
End Sub

Private Sub CreateThumbPic(picSource As PictureBox, picThumb As PictureBox)

    Dim lRet            As Long
    Dim lLeft           As Long
    Dim lTop            As Long
    Dim lWidth          As Long
    Dim lHeight         As Long
    Dim lForeColor      As Long
    Dim hBrush          As Long
    Dim hDummyBrush     As Long
    Dim lOrigMode       As Long
    Dim fScale          As Single
    Dim uBrushOrigPt    As PointAPI

    picThumb.Width = 64
    picThumb.Height = 64
    picThumb.BackColor = vbButtonFace
    picThumb.AutoRedraw = True
    picThumb.Cls
    
    If picSource.Width <= picThumb.Width - 2 And picSource.Height <= picThumb.Height - 2 Then
        fScale = 1
    Else
        fScale = IIf(picSource.Width > picSource.Height, (picThumb.Width - 2) / picSource.Width, (picThumb.Height - 2) / picSource.Height)
    End If
    lWidth = picSource.Width * fScale
    lHeight = picSource.Height * fScale
    lLeft = Int((picThumb.Width - lWidth) / 2)
    lTop = Int((picThumb.Height - lHeight) / 2)
    
    lForeColor = picThumb.ForeColor
    
    lOrigMode = SetStretchBltMode(picThumb.hdc, STRETCH_HALFTONE)
    hDummyBrush = CreateSolidBrush(lForeColor)
    hBrush = SelectObject(picThumb.hdc, hDummyBrush)
    lRet = UnrealizeObject(hBrush)
    lRet = SetBrushOrgEx(picThumb.hdc, lLeft, lTop, uBrushOrigPt)
    hDummyBrush = SelectObject(picThumb.hdc, hBrush)
    
    '拉伸图片
    lRet = StretchBlt(picThumb.hdc, lLeft, lTop, lWidth, lHeight, _
            picSource.hdc, 0, 0, picSource.Width, picSource.Height, SRCCOPY)
    
    lRet = SetStretchBltMode(picThumb.hdc, lOrigMode)
    hBrush = SelectObject(picThumb.hdc, hDummyBrush)
    lRet = UnrealizeObject(hBrush)
    lRet = SetBrushOrgEx(picThumb.hdc, uBrushOrigPt.x, uBrushOrigPt.y, uBrushOrigPt)
    hDummyBrush = SelectObject(picThumb.hdc, hBrush)
    lRet = DeleteObject(hDummyBrush)
    picThumb.ForeColor = lForeColor
    picThumb.Line (lLeft - 1, lTop - 1)-Step(lWidth + 1, lHeight + 1), &H0&, B
    
End Sub

Private Sub CreateThumbs()

    Dim iMaxLen As Integer
    Dim x       As Long
    Dim y       As Long
    Dim lIdx    As Long
    Dim lPicCnt As Long
    Dim lFilCnt As Long
    Dim sPath   As String
    Dim sText   As String
   
   Dim tmplHour, tmpDatePart As Integer
       tmplHour = Hour(Time)
   If tmplHour >= Lunch1 And tmplHour < Lunch2 Then   '中午
      tmpDatePart = 1
     ElseIf tmplHour >= Supper1 And tmplHour < Supper2 Then   '下午
      tmpDatePart = 2
     ElseIf tmplHour >= Night1 And tmplHour < NIght2 Then     '晚上
      tmpDatePart = 3
     Else
      tmpDatePart = 1
   End If
   
   Screen.MousePointer = vbHourglass
    
   Dim DB As Connection, EF As Recordset, HH As Integer
   Set DB = CreateObject("ADODB.Connection")
       DB.Open Constr
       
   Set EF = CreateObject("ADODB.Recordset")
       EF.Open "Select * From SiteType " & sWhere & " Order By Class ASC", DB, adOpenStatic, adLockReadOnly, adCmdText
        
    picSlide.Move 0, 0, optThumb(0).Width, optThumb(0).Height
    picSlide.Visible = False
    picSlide.BackColor = vbButtonFace
    Set picSlide.Font = optThumb(0).Font
    While optThumb.Count > 1
          Unload optThumb(optThumb.Count - 1)
    Wend
    DoEvents
    Dim retVal As Long
    If Not (EF.EOF And EF.BOF) Then
         On Error Resume Next
         lFilCnt = lCount
         
         Dim sPD, sPN
         If lCount > 0 Then
             Call StartProgress
             Dim sFieldValue As String
             For lIdx = 0 To lCount - 1
                '名称
                 sPD = EF.Fields("Class")
                '包厢费
                 Select Case tmpDatePart
                  Case 1
                    sPN = EF.Fields("Price")
                  Case 2
                    sPN = EF.Fields("SupperPrice")
                  Case 3
                    sPN = EF.Fields("NightPrice")
                 End Select
                '装图片
                 Call UpdateProgress((CSng(lIdx + 1) / CSng(lFilCnt)) * 100, sFieldValue)
                 Set picLoad.Picture = LoadPicture()
                     picLoad.Cls
                     Err.Clear
                 Select Case EF("SiteStatus")
                   Case 0
                     picLoad.Picture = picIde.Picture
                   Case 1
                     picLoad.Picture = PicBook.Picture
                   Case 2
                     picLoad.Picture = PicBusy.Picture
                   Case 3
                     picLoad.Picture = picCheck.Picture
                   Case 4
                     picLoad.Picture = picMaintenance.Picture
                 End Select
                 If Err.Number = 0 Then
                     Call CreateThumbPic(picLoad, picThumb)
                    '写桌号
                     retVal = TextOut(picThumb.hdc, 3, 2, sPD, LenB(StrConv(sPD, vbFromUnicode)))
                     If lPicCnt > 0 Then
                         Load optThumb(lPicCnt)
                         Set optThumb(lPicCnt).Container = picSlide
                     End If
                    '1表示为预订，2 为使用中
                     optThumb(lPicCnt).Tag = Trim(str(EF("SiteStatus"))) & sPD
                     Set optThumb(lPicCnt).Picture = picThumb.Image  '显示产品图片
                     
                     Select Case EF("SiteStatus")
                       Case 0
                          optThumb(lPicCnt).ForeColor = &H8000&
                          sText = "○" & sPD & vbCrLf & "包厢费" & sPN & "元"          '显示备注
                          optThumb(lPicCnt).ToolTipText = sText
                       Case 1
                          optThumb(lPicCnt).ForeColor = &H800000
                          sText = "◎" & sPD & vbCrLf & "包厢费" & sPN & "元"          '显示备注
                          optThumb(lPicCnt).ToolTipText = sText
                       Case 2
                          optThumb(lPicCnt).ForeColor = &H40C0&
                          sText = "●" & sPD & vbCrLf & "包厢费" & sPN & "元"         '显示备注
                          optThumb(lPicCnt).ToolTipText = sText
                       Case 3
                          optThumb(lPicCnt).ForeColor = &H40C0&
                          sText = "●" & sPD & vbCrLf & "已经结帐"         '显示备注
                          optThumb(lPicCnt).ToolTipText = sText
                       Case 4
                          optThumb(lPicCnt).ForeColor = &H0&
                          sText = "●" & sPD & vbCrLf & "维修  暂停"                   '显示维修信息
                          optThumb(lPicCnt).ToolTipText = sText
                     End Select
                     iMaxLen = optThumb(lPicCnt).Width - 8
                     If picSlide.TextWidth(sText) > iMaxLen Then
                         iMaxLen = iMaxLen - picSlide.TextWidth("...")
                     End If
                     While picSlide.TextWidth(sText) > iMaxLen
                          sText = Left$(sText, Len(sText) - 1)
                     Wend
                     If iMaxLen < optThumb(lPicCnt).Width - 8 Then
                         sText = sText & "..."
                     End If
                     optThumb(lPicCnt).Caption = sText
                     optThumb(lPicCnt).Visible = True
                     lPicCnt = lPicCnt + 1
                 End If
                 EF.MoveNext
             Next lIdx
             
             picProgress.Visible = False
             
             Set picLoad.Picture = LoadPicture()
             Set picThumb.Picture = LoadPicture()
             picSlide.Visible = True
         End If
         
    End If
    Screen.MousePointer = vbDefault
    EF.Close
    DB.Close
    Set EF = Nothing
    Set DB = Nothing
    
End Sub

Private Sub StartProgress()

    With picProgress
        .Cls
        .BackColor = vbButtonFace
        .ForeColor = vbButtonText
    End With
    
    With picProgressSlide
        .Cls
        .BackColor = vbHighlight
        .ForeColor = vbHighlightText
    End With
    
    picProgress.Visible = True
    
End Sub

Private Sub UpdateProgress(ByVal iPercent As Integer, ByVal sCaption As String)

Dim lTextTop    As Long

    picProgress.Cls
    picProgressSlide.Cls
    picProgressSlide.Width = picProgress.ScaleWidth * (CSng(iPercent) / 100!)
    lTextTop = (picProgress.ScaleHeight - picProgress.TextHeight(sCaption)) / 2
    picProgress.CurrentX = 3
    picProgress.CurrentY = lTextTop
    picProgress.Print sCaption
    picProgressSlide.CurrentX = 3
    picProgressSlide.CurrentY = lTextTop
    picProgressSlide.Print sCaption
    DoEvents
    
End Sub