mdldata.bas

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

Attribute VB_Name = "OAMinModu"
Public CNLinkString As String, GMainDBCNClient As New ADODB.Connection, GMainDBCNServer As New ADODB.Connection
Public LocalLinkString As String, GMainDBCNLocal As New ADODB.Connection
Public PubOAKey As String, PubOAParentKey As String
Public GLanguageID As String, EmailStyle As Integer, intMax As Integer
Public LoginName As String, LinkServerName As String
Public PubOAEmailID As String, strAccountName As String
Declare Function getComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Sub Main()

    LocalLinkString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source= " & App.Path & "\sysGALAXY.mdb"
   ' MsgBox "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=D:\Galaxy\sysGALAXY.mdb"
    GLanguageID = "1"
    
    '    pub_Splash.Show
    '    DoEvents
    '    On Error GoTo Err_Main
    '    getcnclient
    '    frmNewAccount.Show
    'frmPubOAUserMain.Show
    frmSelectAccount.Show
    '   frmLogin.Show 1
    '
    'Err_Main:
    '    Exit Sub
    '
    ''    IEBOX.Navigate App.Path & "\PubOAWelcome.vbd"
    'MoneyMain
    ''    IEBOX.Visible = True
End Sub
    
Public Function LocalComputerName() As String
    Dim i As Integer
    On Error GoTo Err_getComputerName
    i = 1
    s$ = String$(20, 0)
    Dim dl&
    Dim sz&
    sz& = 20
    dl& = getComputerName(s$, sz)
    LocalComputerName = ""
    
    If dl& = 0 Then Exit Function
    
    For i = 1 To 20
        If Mid(s$, i, 1) <> Chr(0) Then
            LocalComputerName = LocalComputerName & Mid(s$, i, 1)
        Else
            Exit For
        End If
    Next
    
    Exit Function
    
Err_getComputerName:
    MisMsg "LocalComputerName Error :" & Err.Description
    LocalComputerName = ""
    Exit Function
End Function


Public Function GetCNClient() As ADODB.Connection
    
    On Error GoTo Err_GetCNClient
    If GMainDBCNClient.State = 0 Then
       GMainDBCNClient.CursorLocation = adUseClient
       GMainDBCNClient.Open CNLinkString
    End If
    Set GetCNClient = GMainDBCNClient
    
Exit_GetCNClient:
    Exit Function
Err_GetCNClient:
    MisMsg "GetCNClient Error: 数据库不能连接!" & Err.Description
    End
End Function
Public Function GetCNServer() As ADODB.Connection
    
    On Error GoTo Err_GetCNServer
    If GMainDBCNServer.State = 0 Then
       GMainDBCNServer.CursorLocation = adUseServer
       GMainDBCNServer.Open CNLinkString
    End If
    Set GetCNServer = GMainDBCNServer
    
Exit_GetCNServer:
    Exit Function
Err_GetCNServer:
    MisMsg "GetCNServer Error: 数据库不能连接!" & Err.Description
    End
End Function

Public Function GetCNLocal() As ADODB.Connection
    
    On Error GoTo Err_GetCNLocal
    If GMainDBCNLocal.State = 0 Then
       GMainDBCNLocal.CursorLocation = adUseClient
       GMainDBCNLocal.Open LocalLinkString
    End If
    Set GetCNLocal = GMainDBCNLocal
Exit_GetCNLocal:
    Exit Function
Err_GetCNLocal:
    MisMsg "GetCNLocal Error: 数据库不能连接!" & Err.Description
    End
End Function

Public Sub GGetRes(LanguageID As String, FrmForm As Form)
  Dim tObj As Control, i As Integer
  On Error GoTo Err_GGetres
  'FrmForm.Caption = LoadResString(FrmForm.Caption & LanguageID)
  For Each tObj In FrmForm.Controls
    Select Case Trim(LCase(TypeName(tObj)))
        Case "commandbutton"
           tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
        Case "treeview"
        Case "combobox"
        Case "toolbar"
            For i = 1 To tObj.Buttons.Count
                If tObj.Buttons(i).Caption <> "-" Then
                    tObj.Buttons(i).Caption = LoadResString(Val(tObj.Buttons(i).Caption & LanguageID))
                End If
            Next
        Case "label"
           tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
        Case "optionbutton"
           tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
        Case "frame"
           tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
        
        Case "sstab"
            For i = 0 To tObj.Tabs - 1
    
                tObj.TabCaption(i) = LoadResString(Val(tObj.TabCaption(i) & LanguageID))
            Next i
    End Select
  Next tObj
  Exit Sub
Err_GGetres:
    MisMsg "GGetRes Error:" & Err.Description
    Exit Sub
End Sub
Public Sub MisMsg(strMsg As String)

     MsgBox strMsg, vbOKOnly + vbExclamation, LoadResString(Val("2674" & GLanguageID))

End Sub

Public Function mis_Entry(FuncID As String, EntryType As Integer) As Integer
On Error GoTo Err_mis_Entry
    Dim rstEntry As Recordset
    Set rstEntry = New Recordset
    mis_Entry = 0
    
    If LoginName = "Admin" Then
        mis_Entry = 1
        Exit Function
    End If
    
    Select Case EntryType
        Case 1
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![AllowNew]
            End If
        Case 2
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![AllowUpdate]
            End If
        Case 3
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![OnlyRead]
            End If
        Case 4
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![Check]
            End If
        Case 5
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![Post]
            End If
    
        Case 6
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![rs]
            End If
        Case Else
                mis_Entry = 0
        
    End Select
    
    Exit Function

Err_mis_Entry:
    MisMsg "mis_Entry Error : " & Err.Description
    Exit Function
End Function



Public Function FlowPower(FuncID As String, billno As String, PowerID As Integer) As Integer
'On Error GoTo Err_FlowPower
    Dim rstFlowPower As Recordset, rstUserWork As Recordset
    FlowPower = 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 "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
        
    FlowPower = 1
    
    Exit Function
Err_FlowPower:
    MisMsg "FlowPower Error : " & Err.Description
    FlowPower = 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 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