module1.bas

考勤系统,智能判断刷卡异常,是一大型ERP系统的一个分支

Attribute VB_Name = "Module1"
Public Sub AddRecord()

Dim mDB As New mDB
Dim AmDB As New mDB

Dim strSQL  As String
Dim adoprimaryRS As ADODB.Recordset
Dim strSQL2  As String
Dim adoPrimaryRS2 As ADODB.Recordset
Dim strSQL3  As String
Dim adoPrimaryRS3 As ADODB.Recordset
Dim strSQL4  As String
Dim adoprimaryRS4 As ADODB.Recordset
Dim strSQL5 As String
Dim adoPrimaryRS5 As ADODB.Recordset

' On Error Resume Next
' On Error GoTo Err1

Dim strConA As String
Dim strConS As String



'    Dim mancount As Integer
'
'    Dim i As Integer
'    ReDim mvList(List1.ListCount - 1)
'    'Dim strList As String
'    'strList = ""
'
'    For i = 0 To List1.ListCount - 1
'        mvList(i) = List1.List(i)
'        'strList = strList & "'" & List1.List(i) & "'" & ","
'        'Debug.Print mvList(i)
'    Next i
'    'strList = Left(strList, Len(strList) - 1)

strConA = "Provider=msdasql;uid=;pwd=;dsn=KaoQin;"
strConS = SQLConnDR
'Debug.Print strConS

mDB.InitDB_RY strConS
AmDB.InitDB_RY strConA


Screen.MousePointer = 11
'strSQL = "update IOData set flg=0"    '''' where (IOGateName not like '一层%' or IOGateName not like '%考勤点%')"

strSQL = "update IOData set flg=true where (IOGateName not like '一层%')"
AmDB.ExecuteSQL strSQL
'strSQL = "update IOData set flg=true where (IOGateName not like '%考勤点%')"
'AmDB.ExecuteSQL strSQL



    
    
    
    
    Dim bgtm As Date
    Dim t1 As Integer
    Dim Maxid As Long


    strSQL = "select max(crdtmid) as maxid from empcrdtm"
    Set adoprimaryRS = mDB.adoprimaryRS(strSQL)
    If IsNull(adoprimaryRS.Fields("maxid").Value) Then
        Maxid = 1
    Else
        Maxid = adoprimaryRS.Fields("maxid").Value
    End If

Dim d As Date
d = InputBox("请输入日期:", , Date)


strSQL2 = "select * from IOData where flg=0 and IODate>=#" & DateAdd("d", -10, d) & "# and IODate<=#" & d & "#"
    Set adoPrimaryRS2 = AmDB.adoprimaryRS(strSQL2)
 Debug.Print strSQL2
 

If MsgBox("将有" & adoPrimaryRS2.RecordCount & "条记录要被传输，确认吗？", vbYesNo) = vbNo Then
Screen.MousePointer = 0
Exit Sub
End If
If adoPrimaryRS2.RecordCount = 0 Then
Screen.MousePointer = 0
Exit Sub
End If


Screen.MousePointer = 11



    strSQL4 = "select  * from empcrdtm where 1=2"
    Set adoprimaryRS4 = mDB.adoprimaryRS(strSQL4)
  
  
  mDB.BeginTrans
 Dim i As Integer
 
With adoPrimaryRS2
    .MoveFirst
    Do While Not .EOF
    adoprimaryRS4.AddNew
    adoprimaryRS4.Fields("crdtmid").Value = Maxid + 1
    adoprimaryRS4.Fields("emplyid").Value = "00" & adoPrimaryRS2.Fields("HolderNo").Value
    adoprimaryRS4.Fields("empcrdno").Value = adoPrimaryRS2.Fields("CardNo").Value
    adoprimaryRS4.Fields("deviceid").Value = Int(Right(adoPrimaryRS2.Fields("IOGateNo").Value, 1))
    adoprimaryRS4.Fields("reasonid").Value = 0
    adoprimaryRS4.Fields("inorout").Value = 1
    adoprimaryRS4.Fields("cdatetime").Value = adoPrimaryRS2.Fields("IODate").Value & " " & adoPrimaryRS2.Fields("IOTime").Value
    adoprimaryRS4.Fields("isovertime").Value = 0
    adoprimaryRS4.Fields("recordtype").Value = 0
    adoprimaryRS4.Fields("operid").Value = adoPrimaryRS2.Fields("DepartmentNo").Value
    adoprimaryRS4.Update
    .Fields("flg").Value = -1
    .Update
   .MoveNext
   Maxid = Maxid + 1
'   i = i + 1
'   If i Mod 1000 = 0 Then
'   Debug.Print "2332079"
'   End If
   
   Loop
End With



 On Error GoTo Err1

mDB.CommitTrans

Screen.MousePointer = 0




    Exit Sub
Err1:
strSQL = "update IOData set flg=0 where (IOGateName not like '一层%' or IOGateName like '%考勤点%') and IODate>=#" & DateAdd("d", -10, d) & "#  and IODate<=#" & d & "#"
AmDB.ExecuteSQL strSQL

    mDB.RollbackTrans
DisPlayErr Err

End Sub



Public Sub TPKaoQin_ManRefresh(ByVal Index As Integer, ByVal Server As String)
    On Error GoTo Err1
    Err.Clear
    Dim db As New mDB
    Dim mDB As New mDB

    Dim strSQL As String
    Dim adoRS As ADODB.Recordset
    Dim adoprimaryRS As ADODB.Recordset
    Dim strSQL2 As String
    Dim adoPrimaryRS2 As ADODB.Recordset
    Dim strSQL3 As String
    Dim adoPrimaryRS3 As ADODB.Recordset



    If MsgBox("你真的要进行人员更新吗？", vbYesNo, "NewAsia") = vbYes Then
        Screen.MousePointer = 11

        Select Case Index
            Case 0

  db.InitDB_SQL Server, "xinya", "reformer", "5148936"
  
  strSQL2 = "select * from bmxxk order by bmbh"
  Set adoPrimaryRS2 = db.adoprimaryRS(strSQL2)
  
  
  
  
  
mDB.InitDB_RY strconnDR
'  mDB.InitDB_SQL "tianping", "refor", "reformer", "5148936"

'  Dim i As Integer
'  Dim iLen As Integer
'  Dim s As String
'  Dim sTmp As String
'
'  adoPrimaryRS2.MoveFirst
'  For i = 2 To adoPrimaryRS2.RecordCount + 1
'  adoPrimaryRS2.Fields("xh").Value = i
'  adoPrimaryRS2.Update
'  adoPrimaryRS2.MoveNext
'  Next i
'
'  Set adoPrimaryRS3 = adoPrimaryRS2.Clone
'
'    adoPrimaryRS2.MoveFirst
'    For i = 0 To adoPrimaryRS2.RecordCount - 1
'    s = adoPrimaryRS2.Fields("bmbh").Value
'    If Len(s) > 2 Then
'    sTmp = Left(s, Len(s) - 2)
'    On Error Resume Next
'
'    adoPrimaryRS3.Find "xh='" & sTmp & "'", 0, adSearchForward, adBookmarkFirst
'    If Not adoPrimaryRS3.EOF Then
'    adoPrimaryRS2.Fields("pxh").Value = adoPrimaryRS3.Fields("xh").Value
'    Else
'    adoPrimaryRS2.Fields("pxh").Value = 0
'    End If
'    End If
'    adoPrimaryRS2.Update
'    adoPrimaryRS2.MoveNext
'    Next i


strSQL = "delete from depart"
mDB.ExecuteSQL strSQL
strSQL = "select * from depart"
Set adoprimaryRS = mDB.adoprimaryRS(strSQL)

With adoPrimaryRS2
    .MoveFirst
    Do While Not .EOF
    adoprimaryRS.AddNew
    adoprimaryRS.Fields("dptid").Value = .Fields("xh").Value
    'adoprimaryRS.Fields("dptno").Value = Format(.Fields("xh").Value, "0000")
    adoprimaryRS.Fields("dptno").Value = .Fields("bmbh").Value
    adoprimaryRS.Fields("dptparent").Value = .Fields("pxh").Value
    adoprimaryRS.Fields("dptname").Value = .Fields("bmmc").Value
    adoprimaryRS.Fields("ify").Value = 1     ''' .Fields("bmmc").Value
    adoprimaryRS.Update
    .MoveNext
    Loop
End With

    

                  strSQL = "select * from zgda_jbxxk"     '''天平
Set adoprimaryRS = db.adoprimaryRS(strSQL)
'                  strSQL = "select * from bmxxk"     '''天平
'Set adoPrimaryRS3 = db.adoPrimaryRS(strSQL)
With adoprimaryRS
    .MoveFirst
    Do While Not .EOF
      adoPrimaryRS2.Find "bmbh='" & .Fields("bmbh").Value & "'", 0, adSearchForward, adBookmarkFirst
  If Not adoPrimaryRS2.EOF Then
  .Fields("zgsg").Value = adoPrimaryRS2.Fields("xh").Value
  .Update
  End If
  .MoveNext
  Loop
  .MoveFirst
  
  End With
  
  
  
  
                 strSQL = "select zcbj,zggh,zgxm,jcsj,lzsj,bmmc from zgda_jbxxk a,bmxxk b where a.bmbh=b.bmbh"     '''天平
        
        
        
         Set adoRS = db.adoprimaryRS(strSQL)

'Debug.Print adoRS.RecordCount


        'Redo:
        strSQL2 = "delete from emply2"
        mDB.ExecuteSQL strSQL2
        '                strSQL2 = "select count(*) from emply2"
        '                Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
        '                If adoPrimaryRS2(0).Value Then GoTo Redo
                
        strSQL3 = "select * from emply"
        Set adoPrimaryRS3 = mDB.adoprimaryRS(strSQL3)
                
        strSQL2 = "select * from emply2"
        Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
        With adoRS
            If .RecordCount = 0 Then Exit Sub


        .MoveFirst
            Do Until .EOF
            If .Fields("zcbj").Value <> 0 Then
                adoPrimaryRS2.AddNew
                adoPrimaryRS2.Fields("ifin").Value = .Fields("zcbj").Value
                adoPrimaryRS2.Fields("partname").Value = .Fields("bmmc").Value
                adoPrimaryRS2.Fields("emplyid").Value = "00" & .Fields("zggh").Value
                adoPrimaryRS2.Fields("emplyname").Value = LeftB(.Fields("zgxm").Value, 8)
                adoPrimaryRS2.Fields("indate").Value = .Fields("jcsj").Value
                adoPrimaryRS2.Fields("outdate").Value = .Fields("lzsj").Value
                '    adoprimaryRS2.Fields("gangwei").Value = .Fields("gangwei").Value
                adoPrimaryRS2.Update
            Else
            'adoPrimaryRS3.Find "emplyid='" & "00" & .Fields("工号").Value & "'", 0, adSearchForward, adBookmarkFirst
            adoPrimaryRS3.Filter = "emplyid='00" & .Fields("zggh").Value & "'"        ''', 0, adSearchForward, adBookmarkFirst
            If adoPrimaryRS3.RecordCount Then
            adoPrimaryRS3.Fields("dptid").Value = 2
'            adoPrimaryRS3.Fields("empbirthday").Value = .Fields("csny").Value
          adoPrimaryRS3.Update
            End If
            End If
            
                .MoveNext
            Loop
'        adoPrimaryRS2.Update
'        adoPrimaryRS3.Update
       End With




  
      

        strSQL = "select * from emply2 where emplyid not in (select emplyid from emply)"
        Set adoRS = mDB.adoprimaryRS(strSQL)


        Screen.MousePointer = 0

        If MsgBox("更新后合计人员——" & adoPrimaryRS2.RecordCount & "其中有" & adoRS.RecordCount & "为新进人员。现在加入吗？", vbYesNo, "NewAsia") = vbYes Then
            strSQL2 = "select top 10 * from emply"
            Set adoPrimaryRS2 = mDB.adoprimaryRS(strSQL2)
            If adoRS.RecordCount Then
                adoRS.MoveFirst
                Do While Not adoRS.EOF
                    With adoPrimaryRS2
                        .AddNew
                        .Fields("dptid").Value = 1
                        .Fields("emplyid").Value = adoRS.Fields("emplyid").Value
                        .Fields("emplyname").Value = adoRS.Fields("emplyname").Value
                        .Update
                    End With
                    adoRS.MoveNext
                Loop
                adoPrimaryRS2.MoveFirst
            End If
        End If




        strSQL = "select zcbj,zggh,zgxm,csny,jcsj,lzsj,zgsg,zgjc,zwbh,zgxb from zgda_jbxxk "     '''天平
Set adoRS = db.adoprimaryRS(strSQL)
        strSQL3 = "select * from emply"
        Set adoPrimaryRS3 = mDB.adoprimaryRS(strSQL3)


'On Error Resume Next
On Error GoTo Err1
        With adoPrimaryRS3
'        MsgBox .RecordCount
            If .RecordCount Then
            .MoveFirst
            End If
            Do While Not .EOF
            adoRS.Find "zggh='" & Mid(.Fields("emplyid").Value, 3) & "'", 0, adSearchForward, adBookmarkFirst
            If Not adoRS.EOF Then
            .Fields("dptid").Value = adoRS.Fields("zgsg").Value
            .Fields("emplyname").Value = adoRS.Fields("zgxm").Value
            .Fields("empsex").Value = IIf(adoRS.Fields("zgxb").Value = "男", 1, 0)
            .Fields("empbirthday").Value = adoRS.Fields("csny").Value
            .Fields("serial").Value = adoRS.Fields("zgjc").Value
            .Fields("empcrdyn").Value = IIf(Len(adoRS.Fields("zgjc").Value) > 1, 1, 0)
            .Fields("duty").Value = Left(adoRS.Fields("zwbh").Value, 10)
            
            .Fields("zcbj").Value = adoRS.Fields("zcbj").Value
            
            .Update
            End If
            .MoveNext
            Loop
            If .RecordCount Then
            .MoveFirst
            End If
        End With
        
             MsgBox "更新OK！"
       
        
            Case 1
        
        
db.InitDB_SQL Server, "XinYa", "reformer", "5148936"
  
  strSQL2 = "select * from bmxxk order by bmbh"
  Set adoPrimaryRS2 = db.adoprimaryRS(strSQL2)
  
  
mDB.InitDB_RY strconnDR

strSQL = "delete from depart"
mDB.ExecuteSQL strSQL
strSQL = "select * from depart"
Set adoprimaryRS = mDB.adoprimaryRS(strSQL)

With adoPrimaryRS2
    .MoveFirst
    Do While Not .EOF
    adoprimaryRS.AddNew
    adoprimaryRS.Fields("dptid").Value = .Fields("xh").Value
    'adoprimaryRS.Fields("dptno").Value = Format(.Fields("xh").Value, "0000")
    adoprimaryRS.Fields("dptno").Value = .Fields("bmbh").Value
    adoprimaryRS.Fields("dptparent").Value = .Fields("pxh").Value