www.pudn.com > 考勤管理系统源码(VB含串口接口程序).zip > 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