modfunction.bas

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

Attribute VB_Name = "modFunction"

Global bLoad As Boolean  '安装完成时
Global bStart As Boolean '安装监视时

Global Condata As String '数据库字符串

Global ConDataServer As String '服务器数据库
Global sMemberStr As String '查询字符串
Global DateStr As String  '日期字符串
Public CancelSearch As Boolean  '取消
Public CC(5) As String
Public sUnit As String   '单位
Public sName As String  '品名
Public sType As String  '类型
Public SCondStr As String '查询条件
Public QueryStr As String '查询字符串表Select * From ***表
Public sSL As Long  '数量
Public SureQuantly As Boolean '确认订购
Public CardNO As String   '卡号
Public cJE As Currency   '讨款时的金额
Public cBXF As Currency  '包厢费
Public nLast As Long 'ID打印号

Public CopyrightOK As Boolean   '版权信息解密OK

Public sCatalog As String   '按菜名分类

Public Us As String  '管理员登录名
Public UserText As String
Public Authority(17) As Boolean
Public sSite As String  '座位
'Public cSiteFee As Currency '包厢费

' COMBO表增量查询
Public Const CB_FINDSTRING = &H14C
Public Const LB_FINDSTRING = &H18F
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

' 打开其它程序
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub Main()

   Constr = ";UID=;PWD=BXS3s44yiA"
   Condata = App.Path & "\SystemData.mdb"
   ConDataServer = GetSetting(App.EXEName, "Config", "NetServer", "")  '服务器数据路径
   
   CheckPath ("")
   
 ' 启动模块
   frmSplash.Show
   
End Sub

Public Sub SaveFormSet(frmSelf As Form)

  On Error Resume Next
  
  If frmSelf.WindowState = 1 Then Exit Sub
     SaveSetting App.EXEName, "Form_Positon", frmSelf.Name & "_Left", frmSelf.Left
     SaveSetting App.EXEName, "Form_Positon", frmSelf.Name & "_Top", frmSelf.Top
  
End Sub

Public Sub GetFormSet(frmSelf As Form, frmContaint As Object)

   On Error Resume Next
   
  ' 缺省值为中心
   If frmSelf.WindowState = 2 Then Exit Sub
   
   frmSelf.Left = GetSetting(App.EXEName, "Form_Positon", frmSelf.Name & "_Left", (frmContaint.Width - frmSelf.Width) / 2)
   frmSelf.Top = GetSetting(App.EXEName, "Form_Positon", frmSelf.Name & "_Top", (frmContaint.Height - frmSelf.Height) / 2)
  
  '防止在桌面以外显示
   If frmSelf.Left > Screen.Width Then
      frmSelf.Left = Screen.Width / 2
   End If
   If frmSelf.Top > Screen.Height Then
      frmSelf.Top = Screen.Height / 2
   End If
   
End Sub

Public Sub SetItFocus(sControl As Control)

    sControl.SelStart = 0
    sControl.SelLength = Len(sControl.Text)
   
End Sub

Public Sub DirectFocus(sHControl As Control, sLControl As Control, sLeftControl, sRightControl, LKey As Integer)

   On Error Resume Next
  
   If LKey = 38 Then  '向上移
      If IsNull(sHControl) Then Exit Sub
      sHControl.SetFocus
      Exit Sub
   End If
   
   If LKey = 40 Or LKey = 13 Then '向下移
      LKey = 0
      If IsNull(sLControl) Then Exit Sub
      sLControl.SetFocus
      Exit Sub
   End If
   
   If LKey = 37 Then '向前
      If IsNull(sLeftControl) Then Exit Sub
      sLeftControl.SetFocus
      Exit Sub
   End If
   
   If LKey = 39 Then '向右
      If IsNull(sRightControl) Then Exit Sub
      sRightControl.SetFocus
      Exit Sub
   End If
   
End Sub

Public Sub CheckPath(strCorrect As String)

    Dim FS As String, FN As Long
    If strCorrect = "" Then
      FS = GetSetting(App.EXEName, "Data", "Path")
    Else
      FS = strCorrect
    End If
     FN = FreeFile
     
On Error GoTo Exist_Err
Open FS For Input As #FN
Close #FN
  Condata = FS
  SaveSetting App.EXEName, "Data", "Path", FS
Exit Sub

Exist_Err:

  MsgBox "网 络 路 径 错 误 , 现 在 启 用 本 地 数 据 库 。        " + vbCrLf + vbCrLf + "   请 重 新 定 义 网 络 数 据 库 的 路 径  ！    ", vbOKOnly + vbExclamation, "网络路径错误"
    
  Condata = Condata
  SaveSetting App.EXEName, "Data", "Path", Condata
   
End Sub

Public Function DelRecord(sWP As String, sFields As String, sTable As String) As Boolean

   On Error GoTo Err_init
   
   Dim DB As Connection
   Dim sEXE As String
   
   Set DB = CreateObject("ADODB.COnnection")
       DB.Open Constr
     ' SQL语言删除
       sEXE = "Delete  From " & sTable & " Where " & sFields & "='" & sWP & "'"
       DB.BeginTrans
       DB.Execute sEXE
       DB.CommitTrans
       DB.Close
       Set DB = Nothing
       DelRecord = True
      
       Exit Function
Err_init:
  DelRecord = False
  MsgBox "记录删除错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Function

'删除会员,curTmp为卡内余额
Public Function DelRecords(sWP As String, curTmp As Currency) As Boolean

   On Error GoTo Err_init
   
   Dim DB As Connection
   Dim sEXE As String
   
   Set DB = CreateObject("ADODB.COnnection")
       DB.Open Constr
       DB.BeginTrans
     
     ' SQL语言删除
       sEXE = "Delete  From tbdMember  Where ID='" & sWP & "'"
       DB.Execute sEXE
       sEXE = "Delete  From Site  Where MID='" & sWP & "'"
       DB.Execute sEXE
       sEXE = "Delete  From tbdArrearage  Where MID='" & sWP & "'"
       DB.Execute sEXE
       sEXE = "Delete  From tbdWastebook  Where MID='" & sWP & "'"
       DB.Execute sEXE
      
      '建立退卡
       If BackCard(DB, curTmp, sWP) = False Then
          DB.RollbackTrans
          DB.Close
          Set DB = Nothing
          Exit Function
       End If
       
       DB.CommitTrans
       DB.Close
       Set DB = Nothing
       DelRecords = True
      
       Exit Function
Err_init:
  DelRecords = False
  MsgBox "记录删除错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
  On Error Resume Next
  DB.RollbackTrans
  DB.Close
  Set DB = Nothing
End Function

Public Function ConVertEncry(sCode As String) As String

      Dim shiftStr As String, shiftStrR As Variant, shiftNum As Integer, ili As Integer, SureStr As String
      shiftStr = Trim(sCode)
      shiftNum = Len(shiftStr)
      ili = 1
      SureStr = ""
        For ili = 1 To shiftNum
            shiftStrR = Mid(shiftStr, ili, 1)
            shiftStrR = Asc(shiftStrR)
            shiftStrR = shiftStrR - 3
            shiftStrR = Chr(shiftStrR)
            SureStr = SureStr & shiftStrR
        Next
      ConVertEncry = SureStr
      
End Function

Public Function NullValue(sFields As Field) As Variant

  On Error Resume Next
  If IsNull(sFields) Then
     NullValue = ""
  Else
     NullValue = sFields.Value
  End If
  
End Function