oaminmodu.bas

一个OA办公自动化管理系统

                             & " Values ('" & NewEmailID & "','" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "','" & rstFlowPower![NextGroupID] + "|" + rstFlowPower![NextTeamID] & "','" & rstFlowPower![NextGroupID] & "','" & rstFlowPower![NextTeamID] & "','" & LoginName & "',' ','" & strTopic & "','" & strPower & "' ,' ',' ',' ',1)"
        
        rstFlowPower.MoveNext
        Loop
        
    FlowPower = 1
    
    Exit Function
Err_FlowPower:
    MisMsg "FlowPower Error : " & Err.Description
    FlowPower = 0
    Exit Function
End Function

Public Function FlowPowerBack(FuncID As String, BillNO As String, PowerID As Integer) As Integer
On Error GoTo Err_FlowPower
    Dim rstFlowPower As Recordset, rstUserWork As Recordset
    FlowPowerBack = 1
    'Stop
    Set rstFlowPower = New Recordset
        rstFlowPower.Open " Select FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "'  Group by FuncName,funcID,FuncPower", GetCNClient, adOpenForwardOnly
        Do Until rstFlowPower.EOF
            Set rstUserWork = New Recordset
            Select Case UCase(rstFlowPower![funcname])
'                Case "ADMIN"
'                    rstUserWork.Open "Select UserID,NextFuncID, FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and FuncName= '" & rstFlowPower![FuncName] & "' and Admin<>0 ", GetCNClient, adOpenForwardOnly
'                    Do Until rstUserWork.EOF
'                        If FlowSendMsg(rstUserWork![UserID], rstUserWork![NextFuncId], rstUserWork![FuncName], BillNO) = 0 Then
'                            MisMsg "发送信息出错！"
'                            Exit Function
'                        End If
'                        rstUserWork.MoveNext
'                    Loop
                
                Case "ALLOWNEW"
                    rstUserWork.Open "Select UserID,NextFuncID, FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and FuncName= '" & rstFlowPower![funcname] & "' and AllowNew<>0 ", GetCNClient, adOpenForwardOnly
                    Do Until rstUserWork.EOF
                        If FlowSendMsg(rstUserWork![UserID], rstUserWork![NextFuncID], rstUserWork![funcname], BillNO) = 0 Then
                            MisMsg "发送信息出错！"
                            Exit Function
                        End If
                        rstUserWork.MoveNext
                    Loop
                Case "ALLOWUPDATE"
                    rstUserWork.Open "Select UserID,NextFuncID, FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and FuncName='" & rstFlowPower![funcname] & "' and AllowUpdate<>0 ", GetCNClient, adOpenForwardOnly
                    Do Until rstUserWork.EOF
                        If FlowSendMsg(rstUserWork![UserID], rstUserWork![NextFuncID], rstUserWork![funcname], BillNO) = 0 Then
                            MisMsg "发送信息出错！"
                            Exit Function
                        End If
                        rstUserWork.MoveNext
                    Loop
                
                Case "CHECK"
                    rstUserWork.Open "Select UserID,NextFuncID, FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and FuncName='" & rstFlowPower![funcname] & "' and [Check]<>0 ", GetCNClient, adOpenForwardOnly
                    Do Until rstUserWork.EOF
                        If FlowSendMsg(rstUserWork![UserID], rstUserWork![NextFuncID], rstUserWork![funcname], BillNO) = 0 Then
                            MisMsg "发送信息出错！"
                            Exit Function
                        End If
                        rstUserWork.MoveNext
                    Loop
                Case "POST"
                    rstUserWork.Open "Select UserID,NextFuncID, FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and FuncName= '" & rstFlowPower![funcname] & "' and Post<>0 ", GetCNClient, adOpenForwardOnly
                    Do Until rstUserWork.EOF
                        If FlowSendMsg(rstUserWork![UserID], rstUserWork![NextFuncID], rstUserWork![funcname], BillNO) = 0 Then
                            MisMsg "发送信息出错！"
                            Exit Function
                        End If
                        rstUserWork.MoveNext
                    Loop
                Case "RS"
                    rstUserWork.Open "Select UserID,NextFuncID, FuncName From v_UserFlow Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and FuncName= '" & rstFlowPower![funcname] & "' and RS<>0 ", GetCNClient, adOpenForwardOnly
                    Do Until rstUserWork.EOF
                        If FlowSendMsg(rstUserWork![UserID], rstUserWork![NextFuncID], rstUserWork![funcname], BillNO) = 0 Then
                            MisMsg "发送信息出错！"
                            Exit Function
                        End If
                        rstUserWork.MoveNext
                    Loop
                
            End Select
            rstFlowPower.MoveNext
        Loop
        
    FlowPowerBack = 1
    
    Exit Function
Err_FlowPower:
    MisMsg "FlowPower Error : " & Err.Description
    FlowPowerBack = 0
    Exit Function
End Function



Public Function FlowSendMsg(UserID As String, FuncID As String, funcname As String, BillNO As String) As Integer
On Error GoTo Err_FlowSendMsg
    FlowSendMsg = 0
    Dim NewEmailID As String, strTopic As String
    NewEmailID = NewID
    strTopic = DLookUp("Explain", "PubOAPower", "FunctionID='" & FuncID & "'") & "(" & BillNO & ")/" & DLookUp("Explain", "PubOAPowerID", "FuncName='" & funcname & "'")
    GetCNLocal.Execute " Insert Into PubOAData( DraftID, SendDate, Addressee, SendMen, CopyTo, Topic, KeyWord, Summary, Accessory, Style) " _
                      & " Values ('" & NewEmailID & "','" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "','" & UserID & "','" & LoginName & "',' ','" & strTopic & "' ,' ',' ',' ',1)"
    
    GetCNClient.Execute " Insert Into PubOAData( DraftID, SendDate, Addressee, SendMen, CopyTo, Topic, KeyWord, Summary, Accessory, Style) " _
                      & " Values ('" & NewEmailID & "','" & Format(Now, "yyyy-mm-dd  hh:mm:ss") & "','" & UserID & "','" & LoginName & "','','" & strTopic & "' ,'','','',0)"
    
    autoSend (UserID)
    FlowSendMsg = 1
    Exit Function
Err_FlowSendMsg:
    MisMsg "FlowSendMsg Error : " & Err.Description
    FlowSendMsg = 0
    Exit Function

End Function

Public Function SendMsg(UserID As String, strMsg As String) As Integer
On Error GoTo Err_SendMsg
    SendMsg = 0
    Dim NewEmailID As String
    NewEmailID = NewID
    'strTopic = DLookUp("Explain", "PubOAPower", "FunctionID='" & FuncID & "'") & "(" & BillNO & ")/" & DLookUp("Explain", "PubOAPowerID", "FuncName='" & FuncName & "'")
    GetCNLocal.Execute " Insert Into PubOAData( DraftID, SendDate, Addressee, SendMen, CopyTo, Topic, KeyWord, Summary, Accessory, Style) " _
                      & " Values ('" & NewEmailID & "','" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "','" & UserID & "','" & LoginName & "',' ','" & strMsg & "' ,' ',' ',' ',1)"
    
    GetCNClient.Execute " Insert Into PubOAData( DraftID, SendDate, Addressee, SendMen, CopyTo, Topic, KeyWord, Summary, Accessory, Style) " _
                      & " Values ('" & NewEmailID & "','" & Format(Now, "yyyy-mm-dd  hh:mm:ss") & "','" & UserID & "','" & LoginName & "','','" & strMsg & "' ,'','','',0)"
    
    autoSend (UserID)
    SendMsg = 1
    Exit Function
Err_SendMsg:
    MisMsg "SendMsg Error : " & Err.Description
    SendMsg = 0
    Exit Function

End Function
Public Function NewID() As String
    On Error GoTo Err_NewID
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open "Select top 1 DraftID From PubOAData  where SendMen='" & LoginName & "' Order  By DraftID desc ", GetCNLocal, adOpenForwardOnly
    If rstEmail.EOF Then
        NewID = "1"
    Else
        NewID = Val(rstEmail![DraftID]) + 1
    End If
    
    Exit Function
Err_NewID:
    MisMsg "NewID Error:" & Err.Description
    Exit Function
End Function

Public Function autoSend(AddrID As String) As Integer
On Error GoTo Err_autoSend
    Dim rstOnline As Recordset
    Set rstOnline = New Recordset
    rstOnline.Open "Select ComputerName From OAOnlineUser Where loginname='" & AddrID & "'", GetCNClient, adOpenForwardOnly
    Do Until rstOnline.EOF
        autoSend = 0
        If LinkServer(rstOnline![ComputerName]) = 0 Then Exit Function
        PubOAMain.tcpClient.SendData LoginName & "你有新任务，请速处理。"
        Warning "1"
        autoSend = 1
        rstOnline.MoveNext
    Loop
    Exit Function
Err_autoSend:
    MisMsg "autoSend Error : " & Err.Description
    Exit Function
    autoSend = 0
End Function

Public Function LinkServer(ServerName As String) As Integer
    
    '返回 0—— 表示连接失败，1——表示连接成功
On Error GoTo Err_LinkServer
    Dim i As Long, j As Long
    LinkServer = 0
    If PubOAMain.tcpClient.State <> 0 Then
        PubOAMain.tcpClient.Close
    End If
    
    If PubOAMain.tcpClient.State = 0 Then
        PubOAMain.tcpClient.Connect ServerName, 1001
'        If Me.TDBGrid1.Columns.Count > 2 Then
'            If IsNull(Me.TDBGrid1.Columns(3).Value) = False Then tcpClient.Connect Me.TDBGrid1.Columns(3).Value, 1001
'        Else
'            If IsNull(Me.TDBGrid1.Columns(1).Value) = False Then tcpClient.Connect Me.TDBGrid1.Columns(1).Value, 1001
'        End If
    End If
    
    i = Timer
    
    Do Until PubOAMain.tcpClient.State = 7
        j = Timer
        If j - i > 10 Then Exit Do
        DoEvents
    Loop
    
    If PubOAMain.tcpClient.State = 7 Then
        LinkServer = 1
    Else
        LinkServer = 0
        MisMsg "连接超时。"
    End If
    Exit Function
Err_LinkServer:
    LinkServer = 0
    MisMsg " LinkServer Error : " & Err.Description
    Exit Function
End Function

Public Sub Warning(Style As String)
    
    If Style = "0" Then
        PubOAMain.Gif89a1.Enabled = False
        PubOAMain.Gif89a1.Visible = False
        
    Else
        PubOAMain.Gif89a1.Enabled = True
        PubOAMain.Gif89a1.Visible = True
    
    End If
    
End Sub

Public Function DataTranns(TabName As String, keyField1 As String, Optional keyField2 As String, Optional keyField3 As String, Optional keyField4 As String, Optional keyField5 As String) As Integer
    DataTranns = 1
    'on Error GoTo Err_DataTranns
    
    Dim rstLocal As Recordset, rstServer As Recordset, i As Integer, LastDate As Date, StrWhere As String
    'MsgBox LocalLinkString
    Set rstLocal = New Recordset
    rstLocal.Open "Select top 1 * From " & TabName & " Order by LastUpdate desc", GetCNLocal, adOpenStatic, adLockReadOnly
    
    If rstLocal.RecordCount > 0 Then
        LastDate = Format(rstLocal![LastUpdate], "yyyy-mm-dd hh:mm:ss")
    Else
        LastDate = Format(Now - 36500, "yyyy-mm-dd hh:mm:ss")
    End If
    
    Set rstServer = New Recordset
    rstServer.Open "Select * From " & TabName & " Where LastUpdate > '" & Format(LastDate, "yyyy-mm-dd hh:mm:ss") & "' Order by LastUpdate ", GetCNClient, adOpenStatic, adLockReadOnly
    If rstServer.RecordCount = 0 Then
        DataTranns = 2
        Exit Function
    End If
    
    Do Until rstServer.EOF
        If keyField1 <> "" Then
            
            If rstServer.Fields(keyField1).Type = adInteger Then
                StrWhere = rstLocal.Fields(keyField1).name & " =" & rstServer.Fields(keyField1).Value & ""
            Else
            'If rstLocal.Fields(keyField1).Type = adChar Then
                StrWhere = rstLocal.Fields(keyField1).name & " ='" & rstServer.Fields(keyField1).Value & "'"
            End If
        End If
        
        If keyField2 <> "" Then
            If rstServer.Fields(keyField2).Type = adInteger Then
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField2).name & " =" & rstServer.Fields(keyField2).Value & ""
            Else
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField2).name & " ='" & rstServer.Fields(keyField2).Value & "'"
            End If
        End If
        
        
        If keyField3 <> "" Then
            If rstServer.Fields(keyField3).Type = adInteger Then
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField3).name & " =" & rstServer.Fields(keyField3).Value & ""
            Else
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField3).name & " ='" & rstServer.Fields(keyField3).Value & "'"
            End If
        End If
        
        If keyField4 <> "" Then
            If rstServer.Fields(keyField4).Type = adInteger Then
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField4).name & " =" & rstServer.Fields(keyField4).Value & ""
            Else
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField4).name & " ='" & rstServer.Fields(keyField4).Value & "'"
            End If
        End If
        
        If keyField5 <> "" Then
            If rstServer.Fields(keyField5).Type = adInteger Then
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField5).name & " =" & rstServer.Fields(keyField5).Value & ""
            Else
                StrWhere = StrWhere & " And " & rstLocal.Fields(keyField5).name & " ='" & rstServer.Fields(keyField5).Value & "'"
            End If
        End If
        'MsgBox "Delete From " & TabName & "  Where " & StrWhere & ""
        GetCNLocal.Execute "Delete From " & TabName & "  Where " & StrWhere & "  "
        
        Set rstLocal = New Recordset
        rstLocal.Open "Select  * From " & TabName & " Where 1=2 ", GetCNLocal, adOpenStatic, adLockOptimistic
        
        rstLocal.AddNew
        
        'transbegin
        For i = 0 To rstLocal.Fields.Count - 1
            rstLocal.Fields(i).Value = rstServer.Fields(rstLocal.Fields(i).name).Value
        Next
        
        rstLocal.Update
        rstServer.MoveNext
    Loop
    rstLocal.Close
    rstServer.Close
    DataTranns = 0