modmain.bas

餐饮管理系统数据库设计文档 表名：bzqbj（保质期报警表） 字段名 字段类型 字段长度 （0表示不允许NULL

Attribute VB_Name = "modMain"
'**********************************************************************************
'**********************************************************************************
'**********************************************************************************
'   酒家信息管理系统主要模块，主要函数
'**********************************************************************************
'**********************************************************************************

Option Explicit
'*************************************************************************************
'*************************************************************************************
'这里设置全局变量，只要求系统公用，需要在不同页面传递的变量，后面加上注释。
'*************************************************************************************
    Public g_susername As String        '全局变量，记录登录人ID
    Public g_spassword As String        '全局变量，记录登录人密码
    Public g_operateright As String     '全局变量，记录登录人的操作权限
    Public g_qtright As String          '全局变量，记录登录人的前台权限
    Public g_isReg As Boolean           '全局变量，记录是否注册过
    Public g_companyid As String        '全局变量，记录当前员工帐套
    
    Public m_room_index As Long         '记录房间INDEX
    Public m_isdj As Boolean            '记录是否点酒状态
    Public m_sjylid(10000) As String    '记录当前酒库中所有的酒类
    
    Public DBServerName As String       '数据库服务器
    Public DBUserName As String         '数据库服务器登录名
    Public DBPassword As String         '数据库服务器登录密码
    Public DBName As String             '数据库名称
  
    Public Const kfmtc = "#,##0.00"     '金额格式
    Public Const sfmtc = "#,##0"        '数量格式

    Public sjylid(10000) As String      '酒库酒id
    Public sjylmc(10000) As String      '酒库酒名
    Public ljsl(10000) As Long          '酒库酒数量

    Public sylid(10000) As String       '原料ID
    Public sylmc(10000) As String       '原料名称
    Public lylsl(10000) As Long         '原料实际数量
    Public lminalert(10000) As Long     '原料最低数量
    Public lmaxalert(10000) As Long     '原料最高数量
    
    Public lbzq(10000) As Long          '原料保质期
    Public lbzyj(10000) As Long         '原料保质预警期
    Public lbzdd(10000) As Long         '原料距保质期间隔
    Public lbzqflag(10000) As Long      '原料保质期标记，1为正常，0为超保质期
    Public Rs1 As New ADODB.Recordset
    Public rs2 As New ADODB.Recordset
    Public temp_dwmc As String
    Public temp_zh As String
    
    
    Public Const KEY_ENTER = 13         '定义Enter键
    
    Private Const SWP_NOMOVE = 2
    Private Const SWP_NOSIZE = 1
    Private Const flags = SWP_NOMOVE Or SWP_NOSIZE
    Private Const HWND_TOPMOST = -1
    Private Const HWND_NOTOPMOST = -2

    Public Type workStatus
        id As String        'auto no
        RoomNm As String    '房间名称
        zh As String        '桌号
        fwy As String       '服务员ID
        rs As Double        '申请人数
        status As Integer   '更新状态
        mode As Integer     '0 :空闲 1：有人
        kssj As String      '开始时间
        jssj As String      '结束时间
    End Type

'这里是系统API的调用声明
    Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
    Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
    Public Declare Function htmlhelp Lib "hhctrl.ocx" Alias "HtmlHelpA" _
                            (ByVal hwndCaller As Long, ByVal pszFile As String, _
                            ByVal uCommand As Long, ByVal dwData As Long) As Long


'**************************************************************************************
'**************************************************************************************
'写入数据库配置文件InitDB.ini,当前路径
'**************************************************************************************
Public Function WriteINIFile(ByVal szSection As String, ByVal szField As String, ByVal szValue As String) As Boolean
On Error GoTo Err_WriteINIFile
    Dim strProcName As String

    strProcName = "WriteINIFile"

    Dim Success As Long
    Success = WritePrivateProfileString(szSection, szField, szValue, App.Path + "\InitDB.INI")
    If Success = False Then
       WriteINIFile = False
    Else
       WriteINIFile = True
    End If
Exit_WriteINIFile:
    Exit Function
Err_WriteINIFile:
    'MsgBox Err.Number & Err.Description & vbCrLf & strProcName, vbCritical
    GoTo Exit_WriteINIFile
End Function

'**************************************************************************************
'**************************************************************************************
'读取数据库配置文件InitDB.ini,当前路径
'**************************************************************************************
Public Function GetINIFile(ByVal szSection As String, ByVal szField As String) As String
On Error GoTo Err_GetINIFile
    Dim strProcName As String
    Dim nRet As Integer
    Dim szFileName As String
    Dim szBuffer As String
    Dim szDefault As String
    Dim nTempLength As Integer

    strProcName = "GetINIFile"

    szDefault = ""
    szBuffer = String(80, " ")
    nRet = GetPrivateProfileString(szSection, szField, szDefault, szBuffer, Len(szBuffer), App.Path + "\InitDB.INI")
    If nRet > 0 Then
        GetINIFile = left(szBuffer, nRet)
    Else
        GetINIFile = szDefault
    End If

Exit_GetINIFile:
    Exit Function
Err_GetINIFile:
    'MsgBox Err.Number & Err.Description & vbCrLf & strProcName, vbCritical
    GoTo Exit_GetINIFile
End Function

'*************************************************************************************
'*************************************************************************************
'打开数据库对象，返回ADODB.Connection对象,SQL Server
'*************************************************************************************
Public Function OpenDB() As ADODB.Connection
On Error GoTo ErrOpenDB
    Dim odb As ADODB.Connection
    Dim odbcnn As String

    Set odb = New ADODB.Connection
    odb.CursorLocation = adUseClient

    odbcnn = "driver={SQL Server};server=" & CStr(DBServerName)
    odbcnn = odbcnn & ";uid=" & CStr(DBUserName) & ";pwd=" & CStr(DBPassword)
    odbcnn = odbcnn & ";database=" & CStr(DBName)

    odb.Open odbcnn
    Set OpenDB = odb
    Set odb = Nothing
Exit Function
ErrOpenDB:
    Set OpenDB = Nothing
End Function

'*************************************************************************************
'*************************************************************************************
'根据SQL语句，打开数据库表对象，返回ADODB.RecordSet对象集
'*************************************************************************************
Public Function GetRsBySQL(ByVal strsql As String) As ADODB.Recordset
On Error GoTo ErrGetRsBySQL
    Dim odb As ADODB.Connection
    Dim rs As ADODB.Recordset
    
    Set odb = OpenDB
    Set rs = New ADODB.Recordset
    rs.CursorLocation = adUseClient
    rs.Open strsql, odb, adOpenDynamic, adLockOptimistic
    Set GetRsBySQL = rs
    Set rs = Nothing
Exit Function
ErrGetRsBySQL:
    Set GetRsBySQL = Nothing
End Function
'*************************************************************************************
'*************************************************************************************
'根据SQL语句，执行Command对象，返回Boolean,bOption为True时锁定
'*************************************************************************************
Public Function ExeSQLByCmd(ByVal strsql As String) As Boolean
On Error GoTo ErrExeSQLByCmd
    Dim odb As ADODB.Connection
    Dim cmd As ADODB.Command
    
    Set odb = OpenDB
    Set cmd = New ADODB.Command
    With cmd
        .ActiveConnection = odb
        .CommandText = strsql
        .CommandType = adCmdText
        .Execute
    End With
    Set cmd = Nothing
    
    Set odb = Nothing
    
    ExeSQLByCmd = True
Exit Function
ErrExeSQLByCmd:
    ExeSQLByCmd = False
End Function


'*************************************************************************************
'*************************************************************************************
'移动Text1输入框到fgd相应的位置
'*************************************************************************************
Public Sub MoveTextInFgd(ByVal Text1 As TextBox, ByVal fgd As MSFlexGrid, _
                        ByVal kRow As Long, ByVal kCol As Long)
On Error Resume Next
    fgd.row = kRow
    fgd.Col = kCol
    
    Text1.Visible = True
    Text1.top = fgd.CellTop + fgd.top
    Text1.left = fgd.CellLeft + fgd.left

    Text1.Width = fgd.CellWidth ' - 2 * Screen.TwipsPerPixelX
    Text1.Height = fgd.CellHeight ' - 2 * Screen.TwipsPerPixelY

    Text1.Text = fgd.Text
    ' Show the text box:
    Text1.Visible = True
    Text1.ZOrder 0 ' 把 Text1 放到最前面！
    Text1.SelStart = 0
    Text1.SelLength = Len(Text1)
    Text1.SetFocus

End Sub

'*************************************************************************************
'*************************************************************************************
'移动combox输入框到fgd相应的位置
'*************************************************************************************
Public Sub MoveComboBoxInFgd(ByVal cob As ComboBox, ByVal fgd As MSFlexGrid, _
                        ByVal kRow As Long, ByVal kCol As Long)
On Error Resume Next
    fgd.row = kRow
    fgd.Col = kCol
    
    cob.Visible = True
    cob.top = fgd.CellTop + fgd.top
    cob.left = fgd.CellLeft + fgd.left

    cob.Width = fgd.CellWidth ' - 2 * Screen.TwipsPerPixelX
    cob.Height = fgd.CellHeight ' - 2 * Screen.TwipsPerPixelY

    cob.Text = fgd.Text
    ' Show the text box:
    cob.Visible = True
    cob.ZOrder 0 ' 把 Text1 放到最前面！
'    cob.SelStart = 0
'    cob.SelLength = Len(cob.Text)
    cob.SetFocus

End Sub
'*************************************************************************************
'*************************************************************************************
'判断权限的时候使用，根据相应的位置得到当前用户是否具有相应的权限
'*************************************************************************************
Public Function GetOperateRight(ByVal iPos As Long) As Boolean
On Error Resume Next
    If Val(GetValueByPos(g_operateright, iPos)) = 1 Then
        GetOperateRight = True
    Else
        GetOperateRight = False
    End If
End Function
'*************************************************************************************
'*************************************************************************************
'判断  前台权限的时候使用，根据相应的位置得到当前用户是否具有相应的权限
'*************************************************************************************
Public Function GetqtRight(ByVal strUserID As String, ByVal strpwd As String, ByVal iPos As Long) As Boolean
On Error Resume Next
    Dim rs As ADODB.Recordset
    Dim strsql As String
    Dim strqtqx As String
    
    GetqtRight = False
    strsql = "select pwd,qtqx from employees where employee_id='" & strUserID & "' and company_id='"
    strsql = strsql & g_companyid & "'"

    Set rs = GetRsBySQL(strsql)
    
    If rs.RecordCount = 0 Then
        GetqtRight = False
        Exit Function
    End If
    
    If LCase(Trim(rs("pwd"))) = LCase(Trim(strpwd)) Then
        strqtqx = rs("qtqx")
        If GetValueByPos(strqtqx, iPos) = 1 Then
            GetqtRight = True
        Else
            GetqtRight = False
        End If
    Else