modmain.bas

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

        GetqtRight = False
    End If
    rs.Close
    Set rs = Nothing
End Function

'*************************************************************************************
'*************************************************************************************
'判断权限的时候使用，根据相应的位置得到当前用户是否具有相应的权限
'*************************************************************************************
Public Function GetValueByPos(ByVal str As String, ByVal pos As Long) As String
On Error Resume Next
    
    GetValueByPos = left(right(str, Len(str) - pos + 1), 1)
    
End Function

'*************************************************************************************
'*************************************************************************************
'判断下拉框的值是否合法。
'*************************************************************************************
Public Function ValidateComboBox(ByVal oCob As ComboBox) As Boolean
On Error Resume Next
    Dim t As Long
    
    ValidateComboBox = False
    With oCob
        For t = 0 To .ListCount - 1
            If .Text = .List(t) Then
                ValidateComboBox = True
                Exit For
            End If
        Next
    End With
End Function

'*************************************************************************************
'*************************************************************************************
'初始化FlexGrid的各项属性，在有FlexGrid的地方初始化的时候调用。
'*************************************************************************************
Public Sub SetPropFgd(ByVal oFgd As MSFlexGrid)
On Error Resume Next
    Dim i As Long
    
    With oFgd
        'General
        .ScrollBars = flexScrollBarBoth
        .HighLight = flexHighlightAlways
        .FocusRect = flexFocusLight
        .MousePointer = flexDefault
'        .FillStyle = flexFillSingle
'        .SelectionMode = flexSelectionByRow
        .AllowUserResizing = flexResizeNone
        
        For i = 0 To .Cols - 1
            .FixedAlignment(i) = flexAlignCenterCenter
        Next
        'style
        .GridLines = flexGridInset
        .TextStyle = flexTextFlat
        .MergeCells = flexMergeNever
        .GridLinesFixed = flexGridInset
        .TextStyleFixed = flexTextInsetLight
        .PictureType = flexPictureColor
        
        'color
        .BackColor = RGB(227, 227, 227)
        .BackColorBkg = RGB(1, 54, 86)
        .BackColorFixed = RGB(175, 175, 175)
        '.BackColorFixed = RGB(227, 227, 227)
        .BackColorSel = RGB(255, 128, 0)
        .ForeColor = RGB(0, 0, 124)
        .ForeColorFixed = vbRed
        .ForeColorSel = vbYellow
        .GridColor = RGB(227, 227, 227)
        .GridColorFixed = vbBlack
    End With
End Sub

'*************************************************************************************
'*************************************************************************************
'验证当前用户登录ID是否有效
'*************************************************************************************
Public Function ValidateUser(ByVal sUserName As String, ByVal sPwd As String) As Boolean
On Error GoTo Err_ValidateUser
    Dim rs As ADODB.Recordset
    Dim strsql As String
    
    ValidateUser = False
    
    strsql = "select pwd,qx,qtqx from employees where employee_id='" & g_susername & "' and"
    strsql = strsql & " company_id='" & g_companyid & "'"
    Set rs = GetRsBySQL(strsql)
    
    If rs.RecordCount = 0 Then GoTo Err_ValidateUser
    
    '*********************************************************************************
    g_operateright = ""
    g_qtright = ""
    If rs("pwd") = sPwd Then
        ValidateUser = True
        g_operateright = rs("qx")
        g_qtright = rs("qtqx")
    End If
    '*********************************************************************************
    rs.Close
    Set rs = Nothing
Exit Function
Err_ValidateUser:
    ValidateUser = False
End Function

Public Function noComma(ByVal txt As String) As Double
On Error Resume Next
    Dim obj As New sp_dzm.dzm
    
    noComma = obj.getValueComma(txt)
    
    Set obj = Nothing
End Function

'*************************************************************************************
'*************************************************************************************
'时间格式转换(1400 To 14:00),只能转化4到6位
'*************************************************************************************
Public Function getstrTime(ByVal longstr As String, ByVal length As Long) As String
On Error Resume Next
    getstrTime = ""
    If Len(longstr) <> length Then Exit Function
    If length = 4 Then
        getstrTime = left(longstr, 2) & ":" & right(longstr, 2)
    ElseIf length = 6 Then
        getstrTime = left(longstr, 2) & ":" & Mid(longstr, 3, 2) & ":" & right(longstr, 2)
    End If
    If IsDate(getstrTime) = False Then getstrTime = ""
End Function

'*************************************************************************************
'*************************************************************************************
'时间格式转换(14:00 To 1400),只能转化4到6位
'*************************************************************************************
Public Function getlongTime(ByVal strtime As String) As String
On Error Resume Next
    getlongTime = Val(Replace(strtime, ":", ""))
    If getlongTime = 0 Then getlongTime = ""
End Function

'*************************************************************************************
'*************************************************************************************
'得到最新的单号，插入时使用
'*************************************************************************************
Public Function getDh(ByVal kbn As String, ByRef code As String) As Boolean
On Error GoTo errProc:
    'kbn 传入单号区分
    Dim wksql As String
    Dim rs As New ADODB.Recordset
    
    getDh = False
    code = ""
    wksql = "SELECT * FROM DHB "
    wksql = wksql & " WHERE val2='" & kbn & "'"
    Set rs = GetRsBySQL(wksql)
    If rs.RecordCount <= 0 Then Exit Function
    code = rs!val2 & rs!bz & (rs!val1 + 1)
    wksql = "UPDATE DHB SET "
    wksql = wksql & " VAL1=VAL1+1"
    wksql = wksql & " WHERE VAL2='" & kbn & "'"
    Call ExeSQLByCmd(wksql)
    getDh = True
    Exit Function
errProc:
    getDh = False
End Function

'*************************************************************************************
'*************************************************************************************
'隐藏所有frame
'*************************************************************************************
Public Sub ShutAllFrame()
On Error Resume Next
    Unload frmxgmm
    
    With frmMain
        .fmMain.Visible = False
        .fmyysz.Visible = False
        .fmxtgl.Visible = False
        .fmjygl.Visible = False
    End With
End Sub

'*************************************************************************************
'*************************************************************************************
'得到酒库的实际信息
'*************************************************************************************
Public Function GetJKValue() As Boolean
On Error GoTo err_getjkvalue
    Dim rs As ADODB.Recordset
    Dim strsql As String
    Dim i As Long
    
    strsql = "select jkkcb.ylid,ylmc from jkkcb,ylmcb where jkkcb.ylid=ylmcb.ylid order by jkkcb.ylid,ylmc,sl"
    
    Set rs = GetRsBySQL(strsql)
    
    If rs.RecordCount = 0 Then GoTo err_getjkvalue
    
    For i = 0 To rs.RecordCount - 1
        sjylid(i) = rs("ylid")
        sjylmc(i) = rs("ylmc")
'        ljsl(i) = rs("sl")
        
        rs.MoveNext
    Next
    rs.Close
    Set rs = Nothing
    
    GetJKValue = True
    
Exit Function
err_getjkvalue:
    GetJKValue = False
End Function

'*************************************************************************************
'*************************************************************************************
'得到当前库存的实际数量信息
'*************************************************************************************
Public Function GetKcValue() As Boolean
On Error GoTo err_GetKcValue

    Dim rs As ADODB.Recordset
    Dim strsql As String
    Dim i As Long
    
    GetKcValue = False
    
    For i = 0 To 9999
        sylid(i) = ""
        sylmc(i) = ""
        lylsl(i) = -1
        lminalert(i) = -1
        lmaxalert(i) = -1
        lbzq(i) = -1
        lbzyj(i) = -1
    Next
    
    strsql = "select distinct bzq,bzyjq,kcb.ylid,ylmcb.ylid,ylmc,sl,minalert,"
    strsql = strsql & "maxalert from kcb,ylmcb where kcb.ylid=ylmcb.ylid"
    Set rs = GetRsBySQL(strsql)
    
    If rs.RecordCount = 0 Then GoTo err_GetKcValue
    
    For i = 0 To rs.RecordCount - 1
        sylid(i) = rs("ylid")
        sylmc(i) = rs("ylmc")
        lylsl(i) = rs("sl")
        lminalert(i) = rs("minalert")
        lmaxalert(i) = rs("maxalert")
        lbzq(i) = rs("bzq")
        lbzyj(i) = rs("bzyjq")
        rs.MoveNext
    Next
    
    rs.Close
    Set rs = Nothing
    
    GetKcValue = True
    Exit Function
err_GetKcValue:
    GetKcValue = False
End Function
'*************************************************************************************
'*************************************************************************************
'得到当前库存的数量警告信息
'*************************************************************************************
Private Function GetiByylid(ByVal sylid1 As String) As Long
    Dim i As Long
    
    For i = 0 To 9999
        If sylid(i) = sylid1 Then
            GetiByylid = i
            Exit For
        End If
    Next

End Function

'*************************************************************************************
'*************************************************************************************
'得到当前库存的数量警告信息
'*************************************************************************************
Public Sub GetKCSLAlert()
On Error Resume Next
    Dim i As Long
    Dim strmsg As String
    Dim strsql As String
    
    Call GetKcValue
    
    strsql = "delete from kcslbj"