modfunction.bas

这是温州现代集团的员工考勤管理系统

Attribute VB_Name = "modFunction"
Option Explicit

'Global Const LISTVIEW_BUTTON = 11 '系统


'Public fMainForm As frmMain '系统


Sub Main()

    AppPath = App.Path
    gToday = Format(Date, "yyyy-mm-dd")
    SetHandIco
    IniVariant
    
    IniItem "t_baccountitem", aAccount()
    IniItem "t_bcheckflagitem", aCheckFlag()
    IniCurrency
    IniItem "t_bcustomeritem", aCustomer()
    IniItem "t_binitem", aIn()
    IniItem "t_bnationalityitem", aNationality()
    IniItem "t_bpaperitem", aPaper()
    IniItem "t_bpayitem", aPay()
    IniItem "t_broomitem", aRoomType()
    IniItem "t_bsellflagitem", aSellFlag()
    IniItem "t_broomstatusitem", aRoomStatus()
    IniItem "t_bsexitem", aSex()
    IniItem "t_bvipitem", aVip()
    aRoomType(0).Name = "所有房类"
    aCustomer(0).Name = "所有客类"
    aVip(0).Name = "所有VIP标志"
    IniFloors
    IniRooms
    
    On Error GoTo ErrHandle
    '********InStatus
    gInStatusFlag = aIn(1).ID
    gLeaveStatusFlag = aIn(2).ID
    gOrderStatusFlag = aIn(3).ID
    
    '********CheckItem
    gNotCheckFlag = aCheckFlag(1).ID
    gPartCheckFlag = aCheckFlag(2).ID
    gFullCheckFlag = aCheckFlag(3).ID
    gDoingCheckFlag = aCheckFlag(4).ID
    
    '********AccountItem
    gOrderAccountFlag = aAccount(1).ID
    gRentAccountFlag = aAccount(2).ID
    gForeAccountFlag = aAccount(3).ID
    
    gWorkID = "user"
        
'    frmFace.Show
    frmOrder.mIsLogin = False
    frmOrder.Show
    'frmOrdQry.Show
    ExitApp
'    frmSplash.Show
'    frmSplash.Refresh
'    Set fMainForm = New frmMain
'    Load fMainForm
'    Unload frmSplash
''*========系统
'
'    fMainForm.Show
    Exit Sub
ErrHandle:
    MsgBox "数据库中内定的数据被改动," & vbCrLf & _
        "请系统管理员检查后重新启动!", , gTitle
    Err.Clear
End Sub

Private Sub IniCurrency()
    ReDim aCurrency(0)
    aCurrency(0).ID = gMAXITEM
    
    Dim Rst As rdoResultset
    Dim i As Integer
    Dim isSame As Boolean
    
    On Error GoTo ErrHandle
    Set Rst = gCn.OpenResultset("select * from t_bcurrencyitem order by F_ID", _
        rdOpenForwardOnly, rdConcurReadOnly, rdAsyncEnable + rdExecDirect)
    
    While Rst.StillExecuting
        Debug.Print "CurrencyItem";
        DoEvents
    Wend
    
    While Not Rst.EOF
        isSame = False
        For i = 0 To UBound(aCurrency)
            If Trim(Rst!F_ID) = Trim(aCurrency(i).ID) Then
                isSame = True
                Exit For
            End If
        Next
        If Not isSame Then
            ReDim Preserve aCurrency(UBound(aCurrency) + 1)
            With aCurrency(UBound(aCurrency))
                .ID = Trim(Rst!F_ID)
                .Name = IIf(IsNull(Rst!F_ItemName), "", Trim(Rst!F_ItemName))
                .Rate = IIf(IsNull(Rst!F_Rate), 0, Format(Rst!F_Rate, "0.000"))
            End With
        End If
        Rst.MoveNext
    Wend
    Rst.Close
    Set Rst = Nothing
    Exit Sub
ErrHandle:
    Dim er As rdoError
    Dim MsgStr As String
    For Each er In rdoErrors
        MsgStr = MsgStr & er.Description & er.Number & vbCrLf
    Next
    MsgBox MsgStr, , gTitle
    Resume Next
End Sub

Private Sub IniRooms()
    ReDim aRooms(0)
    aRooms(0).ID = ""
    Dim Rst As rdoResultset
    Dim i As Integer
    Dim isSame As Boolean
    
    On Error GoTo ErrHandle
    Set Rst = gCn.OpenResultset("select * from t_room order by F_RoomID", _
        rdOpenForwardOnly, rdConcurReadOnly, rdAsyncEnable + rdExecDirect)
    While Rst.StillExecuting
        Debug.Print "Rooms"
        DoEvents
    Wend
    
    While Not Rst.EOF
        isSame = False
        For i = 0 To UBound(aRooms)
            If Trim(Rst!F_RoomID) = Trim(aRooms(i).ID) Then
                isSame = True
                Exit Sub
            End If
        Next
        
        For i = 0 To UBound(aFloors)
            If Left(Trim(Rst!F_RoomID), gFloorIDLen) = Trim(aFloors(i).ID) Then
                With aFloors(i)
                    ReDim Preserve .Rooms(UBound(.Rooms) + 1)
                    .Rooms(UBound(.Rooms)) = Trim(Rst!F_RoomID)
                    Exit For
                End With
            End If
        Next
        
        If Not isSame Then
            ReDim Preserve aRooms(UBound(aRooms) + 1)
            With aRooms(UBound(aRooms))
                .ID = Rst!F_RoomID
                .Name = IIf(IsNull(Rst!F_Name), "", Trim(Rst!F_Name))
                .Type = IIf(IsNull(Rst!F_RoomItem), 0, Rst!F_RoomItem)
                .Status = IIf(IsNull(Rst!F_Status), 0, Rst!F_Status)
                .Phone = IIf(IsNull(Rst!F_Phone), "", Trim(Rst!F_Phone))
                .SellFlag = IIf(IsNull(Rst!F_SellFlag), 0, Rst!F_SellFlag)
                .StandardPrice = IIf(IsNull(Rst!F_StandardPrice), 0, Format(Rst!F_StandardPrice, "0.00"))
                .GroupPrice = IIf(IsNull(Rst!F_GroupPrice), 0, Format(Rst!F_GroupPrice, "0.00"))
                .AddPrice = IIf(IsNull(Rst!F_AddPrice), 0, Format(Rst!F_AddPrice, "0.00"))
                .ClockPrice = IIf(IsNull(Rst!F_ClockPrice), 0, Format(Rst!F_ClockPrice, "0.00"))
                .Capability = IIf(IsNull(Rst!F_Capability), 0, Rst!F_Capability)
                .HaveNumber = IIf(IsNull(Rst!F_HaveNumber), 0, Rst!F_HaveNumber)
                .Rate = IIf(IsNull(Rst!F_Rate), 100, Rst!F_Rate)
                .Discount = IIf(IsNull(Rst!F_Discount), 0, Format(Rst!F_Discount, "0.00"))
            End With
        End If
        Rst.MoveNext
    Wend
    Rst.Close
    Set Rst = Nothing
    Exit Sub
ErrHandle:
    Dim er As rdoError
    Dim MsgStr As String
    For Each er In rdoErrors
        MsgStr = MsgStr & er.Description & er.Number & vbCrLf
    Next
    MsgBox MsgStr, , "错误提示"
    Resume Next
End Sub

Private Sub IniItem(t_table As String, aArray() As ItemStruc)
    ReDim aArray(0)
    aArray(0).ID = gMAXITEM
    
    Dim Rst As rdoResultset
    Dim i As Integer
    Dim isSame As Boolean
    
    On Error GoTo ErrHandle
    Set Rst = gCn.OpenResultset("select * from " & Trim(t_table) & " order by F_ID", _
        rdOpenForwardOnly, rdConcurReadOnly, rdAsyncEnable + rdExecDirect)
    
    While Rst.StillExecuting
        Debug.Print "array";
        DoEvents
    Wend
    
    While Not Rst.EOF
        isSame = False
        For i = 0 To UBound(aArray)
            If Rst!F_ID = aArray(i).ID Then
                isSame = True
                Exit For
            End If
        Next
        If Not isSame Then
            ReDim Preserve aArray(UBound(aArray) + 1)
            With aArray(UBound(aArray))
                .ID = Rst!F_ID
                .Name = IIf(IsNull(Rst!F_ItemName), "", Trim(Rst!F_ItemName))
            End With
        End If
        Rst.MoveNext
    Wend
    Rst.Close
    Set Rst = Nothing
    Exit Sub
ErrHandle:
    Dim er As rdoError
    Dim MsgStr As String
    For Each er In rdoErrors
        MsgStr = MsgStr & er.Description & er.Number & vbCrLf
    Next
    MsgBox MsgStr, , gTitle
    Resume Next
End Sub


Private Sub IniFloors()
    ReDim aFloors(0)
    aFloors(0).ID = ""
    ReDim aFloors(0).Rooms(0)
    aFloors(0).Rooms(0) = ""
    
    Dim Rst As rdoResultset
    Dim i As Integer
    Dim isSame As Boolean
    
    On Error GoTo ErrHandle
    Set Rst = gCn.OpenResultset("select * from t_bflooritem order by F_ID", _
        rdOpenForwardOnly, rdConcurReadOnly, rdAsyncEnable + rdExecDirect)
    
    While Rst.StillExecuting
        Debug.Print "Floors";
        DoEvents
    Wend
    
    While Not Rst.EOF
        isSame = False
        For i = 0 To UBound(aFloors)
            If Trim(Rst!F_ID) = Trim(aFloors(i).ID) Then
                isSame = True
                Exit For
            End If
        Next
        If Not isSame Then
            ReDim Preserve aFloors(UBound(aFloors) + 1)
            With aFloors(UBound(aFloors))
                .ID = Trim(Rst!F_ID)
                .Name = IIf(IsNull(Rst!F_ItemName), "", Trim(Rst!F_ItemName))
                ReDim .Rooms(0)
                .Rooms(0) = ""
            End With
        End If
        Rst.MoveNext
    Wend
    Rst.Close
    Set Rst = Nothing
    Exit Sub
ErrHandle:
    Dim er As rdoError
    Dim MsgStr As String
    For Each er In rdoErrors
        MsgStr = MsgStr & er.Description & er.Number & vbCrLf
    Next
    MsgBox MsgStr, , gTitle
    Resume Next
End Sub
Private Sub IniVariant()
    gFloorIDLen = 2
    gRoomIDLen = 2
    
    Set gEngine = New rdoEngine
    Set gEnvir = gEngine.rdoEnvironments(0)
    
    On Error GoTo CnEh
    Dim CnStr As String
    CnStr = "uid=;pwd=;driver={SQL Server};SERVER=NT40_Server;database=roomdb;"
    Set gCn = gEnvir.OpenConnection(dsName:="RoomData", prompt:=rdDriverCompleteRequired, Connect:=CnStr)
    Set gUCN = New UserConnection1
    gUCN.EstablishConnection
    
    Exit Sub
CnEh:
Dim er As rdoError
    Debug.Print Err, Error
    For Each er In rdoErrors
        Debug.Print er.Description, er.Number & vbCrLf
    Next er
    Resume Next
End Sub

Private Sub ExitApp()
    gCn.Close
    Set gCn = Nothing
    gEnvir.Close
    Set gEnvir = Nothing
    Set gEngine = Nothing
End Sub

Private Sub SetHandIco()
    Dim picPath As String
    picPath = AppPath + "\pic\hand.ico"
    If Dir(picPath) <> "" Then
        Set gicoHand = LoadPicture(picPath)
    End If
End Sub

Public Sub SortGridByCol(myGrid As MSFlexGrid)
    With myGrid
        If .Row = .FixedRows Then
            .Sort = 1
        End If
    End With
End Sub

Public Sub SetGridColor(myGrid As MSFlexGrid)
    With myGrid
        .BackColor = &H80000018  '&HC0FFFF '&HC0FFC0
        .BackColorFixed = &HC0C0C0   '&HC0FFC0
        .ForeColorFixed = &H80000002 '&HC00000   '
        .ForeColor = &H0
        .BackColorSel = &HC00000
        .GridColor = &HC0C0C0
        .GridColorFixed = &H808080  ' &HC0C0C0
        '.ForeColorFixed =
        .BackColorBkg = &H80000018 ' &HFFFFFF ''&HC0FFFF
        .AllowUserResizing = flexResizeColumns
        .ScrollBars = flexScrollBarBoth
    End With
End Sub

Public Sub FillCbo(myCbo As ComboBox, myArray() As ItemStruc, Optional IniValue As Integer = 1) 'optional为所有类别准备
    Dim i As Integer
    With myCbo
        If UBound(myArray) >= 1 Then
            For i = IniValue To UBound(myArray)
                .AddItem myArray(i).Name
                .ItemData(.NewIndex) = myArray(i).ID
            Next
            If .ListCount > 0 Then
                .ListIndex = 0
            End If
        End If
    End With
End Sub

Public Sub LookForCbo(myCbo As ComboBox, intFind As Integer)
    Dim i As Integer
    With myCbo
        For i = 0 To .ListCount - 1
            If .ItemData(i) = intFind Then
                .ListIndex = i
                Exit For
            End If
        Next
    End With
End Sub