📄 oamain.frm

📁 一个OA办公自动化管理系统
💻 FRM
📖 第 1 页 / 共 4 页
字号:
上一页 1 2 34

    Me.lblState.Caption = "     当前任务: 交流--未读信息"


End Sub
Private Sub Read()
    
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open "Select  SendMen, Topic, SendDate, Addressee, KeyWord, Summary, DraftID from PubOAData Where addressee='" & LoginName & "' and Type=1 ", GetCNLocal, adOpenStatic, adLockReadOnly
    Set Me.TDBGrid1.DataSource = rstEmail
    FormatTDGrid
    LoadEmail
    Me.Toolbar1.Buttons(2).Enabled = True
    Me.Toolbar1.Buttons(3).Enabled = False
    Me.Toolbar1.Buttons(4).Enabled = False
    Me.Toolbar1.Buttons(5).Enabled = True

End Sub
Private Sub unSendBox()
    
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open "Select  SendMen, Topic, SendDate, Addressee, KeyWord, Summary, DraftID from PubOAData Where SendMen='" & LoginName & "' and  type=0 and style=0", GetCNLocal, adOpenStatic, adLockReadOnly
    Set Me.TDBGrid1.DataSource = rstEmail
    FormatTDGrid
    LoadEmail
    Me.Toolbar1.Buttons(2).Enabled = True
    Me.Toolbar1.Buttons(3).Enabled = True
    Me.Toolbar1.Buttons(4).Enabled = False
    Me.Toolbar1.Buttons(5).Enabled = True

End Sub

Private Sub TBEnabled()
    Me.Toolbar1.Buttons(2).Enabled = False
    Me.Toolbar1.Buttons(3).Enabled = False
    Me.Toolbar1.Buttons(4).Enabled = False
    Me.Toolbar1.Buttons(5).Enabled = False

End Sub
Private Sub SendBox()
    
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open "Select  SendMen, Topic, SendDate, Addressee, KeyWord, Summary, DraftID from PubOAData Where SendMen='" & LoginName & "'  and Type=0 and   Style=1", GetCNLocal, adOpenStatic, adLockReadOnly
    Set Me.TDBGrid1.DataSource = rstEmail
    FormatTDGrid
    LoadEmail
    Me.Toolbar1.Buttons(2).Enabled = True
    Me.Toolbar1.Buttons(3).Enabled = False
    Me.Toolbar1.Buttons(4).Enabled = False
    Me.Toolbar1.Buttons(5).Enabled = True

End Sub

Private Sub onLine()
    
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open "SELECT LoginName, ComputerName FROM OAOnlineUser", GetCNClient, adOpenStatic, adLockReadOnly
    Set Me.TDBGrid1.DataSource = rstEmail
    Me.TDBGrid1.MarqueeStyle = 4
    Me.TDBGrid1.Columns(0).Caption = "在线用户"
    Me.TDBGrid1.Columns(1).Caption = "计算机名"
    Me.lblSend.Caption = "发送信息"
    Me.lblTopic.Caption = "收到信息"
    Me.Toolbar1.Buttons(2).Enabled = True
    Me.Toolbar1.Buttons(3).Enabled = False
    Me.Toolbar1.Buttons(4).Enabled = False
    Me.Toolbar1.Buttons(5).Enabled = False

End Sub

Private Sub Timer1_Timer()
    'MsgBox Format(Now - 1 / (24 * 12), "yyyy-mm-dd hh:mm:ss")
    GetCNClient.Execute "Delete from OAOnlineUser Where UpdateTime< '" & Format(Now - 1 / (24 * 12), "yyyy-mm-dd hh:mm:ss") & "'"
    GetCNClient.Execute "Update OAOnlineUser set UpdateTime='" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "'      "
'    Dim rstEmail As Recordset
'    Set rstEmail = New Recordset
'    rstEmail.Open "SELECT LoginName, ComputerName FROM OAOnlineUser", GetCNClient, adOpenStatic, adLockReadOnly
'    Set Me.TDBGrid1.DataSource = rstEmail
    
    If Me.VtlMenu.MenuCur = 1 And Me.VtlMenu.MenuItemCur = 5 Then
        onLine
    End If
    TimeWarning
    
End Sub

Public Sub VtlMenu_MenuItemClick(MenuNumber As Long, MenuItem As Long)
On Error GoTo Err_LoadFrom
    Dim i As Integer, rstEmail As Recordset, intIsOA As Integer, s1 As String
    PubOAEmailID = "1"
    Dim f As Form
    Dim s As New clsInput
 
    Set rstEmail = New Recordset
    rstEmail.Open "Select IsOA From AccountName Where AccountId='" & strAccountName & "'", GetCNLocal, adOpenForwardOnly
    If rstEmail.EOF = False Then
        intIsOA = rstEmail![isOA]
    End If
    
    If intIsOA = 1 Then
        Select Case MenuNumber
            
            Case 1
                Select Case MenuItem
                    
                    Case 1
                        EmailStyle = 1
                        UnRead
                    Case 2
                        EmailStyle = 2
                        Read
                    Case 3
                        EmailStyle = 2
                        unSendBox
                    Case 4
                        EmailStyle = 2
                        SendBox
                    
                    Case 5
                        
                        LoadTalk
                        EmailStyle = 2
                        onLine
                    Case Else
                        Me.Picture1.Visible = False
                        Me.Picture2.Visible = False
                End Select
            
            Case 2
                Dim ii As Integer
                Select Case MenuItem
                    Case 1
                        TBEnabled
                        ii = DrawFlow()
                        WorkFlow
                    Case Else
                        Me.MousePointer = 11
                        TBEnabled
                        WorkFlow
                        'ii = DrawFlow()
                        Me.Picture1.Visible = False
                        Me.Picture2.Visible = True
                        AddForm Me.VtlMenu.MenuItemKey
                        Me.MousePointer = 0
                
                End Select
    
    '        Case Is > 2
            Case Is > 2
                Me.MousePointer = 11
                TBEnabled
                WorkFlow
                'ii = DrawFlow()
                Me.Picture1.Visible = False
                Me.Picture2.Visible = True
                AddForm Me.VtlMenu.MenuItemKey
                Me.MousePointer = 0
    
            Case Else
                Me.Picture1.Visible = False
                Me.lblSend.Visible = False
                Me.lblTopic.Visible = False
                Me.RTxtSummary.Visible = False
                
        End Select
    Else
        WorkFlow
        Me.Picture1.Visible = False
        Me.Picture2.Visible = True
        
        Me.VtlMenu.MenuItemCur = MenuItem
        AddForm Me.VtlMenu.MenuItemKey

    End If
    Me.VtlMenu.MenuCur = MenuNumber
    Me.VtlMenu.MenuItemCur = MenuItem
    Me.lblState.Caption = "     当前任务: " & Me.VtlMenu.MenuCaption & "--" & Me.VtlMenu.MenuItemCaption

    Exit Sub
Err_LoadFrom:
    MisMsg "LoadForm Error : " & Err.Description
    Exit Sub
End Sub

Private Sub AddForm(FuncID As String)
    Dim s As clsInput, f As Form
     Select Case UCase(DLookUp("Type", "PubOAPower", "FunctionID='" & FuncID & "'"))
         Case "FORM"
             Set f = Forms.Add(FuncID)
             f.Show 1
         Case "PUBFORM"
             Set s = New clsInput
             s.FormName = FuncID
             s.ShowForm
         Case "QUERY"
             Set s = New clsInput
             s.ShowQuery Mid(FuncID, 2, 100)
         Case "CHECK"
             Set s = New clsInput
             s1 = Trim(Mid(FuncID, 2, 100))
             s.FormName = s1
             s.ShowCheck
         Case "MONEY"
             Set s = New clsInput
             s.FormName = FuncID
             s.ShowMoney
     End Select
     Set s = Nothing

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    Select Case Button.Key
        Case "tbNew"
            EmailStyle = 0
            frmPubOAEMail.Show 1
            UnRead
            'GetEmail NewID
        'Case "tbSave"
            'SaveEmail Me.txtDraftID.Text
        Case "tbSend"
            If IsNull(Me.TDBGrid1.Columns(6).Value) Then Exit Sub
            'MsgBox Me.TDBGrid1.Columns(3).Value
            If autoSend(Me.TDBGrid1.Columns(3).Value) = 1 Then
                SaveServerEmail Me.TDBGrid1.Columns(6).Value
                UpdateLocalEMail Me.TDBGrid1.Columns(6).Value
                
                MisMsg "发送成功！"
            Else
                MisMsg "发送失败！"
            
            End If
            unSendBox
'            SendBox
        Case "tbRead"
            If IsNull(Me.TDBGrid1.Columns(6).Value) Then Exit Sub
            
            SaveLocalEmail Me.TDBGrid1.Columns(6).Value, 1
            DelServerEMail Me.TDBGrid1.Columns(6).Value
            UnRead
            'Read
            'cmdLink_Click
        Case "tbCopyto"
        Case "tbDel"
            If IsNull(Me.TDBGrid1.Columns(6).Value) Then Exit Sub
            
            DelLocalEMail Me.TDBGrid1.Columns(6).Value
            SendBox
    End Select
End Sub

Private Sub SaveLocalEmail(EMailID As String, intType As Integer)
    On Error GoTo err_SaveLocalEmail
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open " Select *  From PubOAData Where DraftID=" & EMailID & " and addressee='" & LoginName & "' and Type=" & intType & " ", GetCNLocal, adOpenStatic, adLockOptimistic
    With rstEmail
        If .EOF Then
            .AddNew
            ![DraftID] = EMailID
            ![SendDate] = Me.TDBGrid1.Columns(2).Value
            ![SendMen] = Me.TDBGrid1.Columns(0).Value & ""
            ![Addressee] = Me.TDBGrid1.Columns(3).Value & ""
            '![CopyTo] = Me.TDBGrid1.Columns(0).Value & ""
            ![Topic] = Me.TDBGrid1.Columns(1).Value & ""
            ![KeyWord] = Me.TDBGrid1.Columns(4).Value & ""
            ![Summary] = Me.TDBGrid1.Columns(5).Value & ""
            '![Accessory] = Me.TDBGrid1.Columns(0).Value & ""
            ![Type] = intType
            .Update
        Else
            ![DraftID] = EMailID
            ![SendDate] = Me.TDBGrid1.Columns(2).Value
            ![SendMen] = Me.TDBGrid1.Columns(0).Value & ""
            ![Addressee] = Me.TDBGrid1.Columns(3).Value & ""
            '![CopyTo] = Me.TDBGrid1.Columns(0).Value & ""
            ![Topic] = Me.TDBGrid1.Columns(1).Value & ""
            ![KeyWord] = Me.TDBGrid1.Columns(4).Value & ""
            ![Summary] = Me.TDBGrid1.Columns(5).Value & ""
            ![Type] = intType
            .Update
        
        End If
    End With
    
    Exit Sub
err_SaveLocalEmail:
    MisMsg "SaveLocalEmail Error:" & Err.Description
    Exit Sub
End Sub

Private Sub SaveServerEmail(EMailID As String)
    On Error GoTo Err_SaveServerEmail
    Dim rstEmail As Recordset
    Set rstEmail = New Recordset
    rstEmail.Open " Select *  From PubOAData Where DraftID=" & EMailID & " and SendMen='" & LoginName & "'", GetCNClient, adOpenStatic, adLockOptimistic
    With rstEmail
        If .EOF Then
            .AddNew
            ![DraftID] = EMailID
            ![SendDate] = Me.TDBGrid1.Columns(2).Value
            ![SendMen] = Me.TDBGrid1.Columns(0).Value & ""
            ![Addressee] = Me.TDBGrid1.Columns(3).Value & ""
            '![CopyTo] = Me.TDBGrid1.Columns(0).Value & ""
            ![Topic] = Me.TDBGrid1.Columns(1).Value & ""
            ![KeyWord] = Me.TDBGrid1.Columns(4).Value & ""
            ![Summary] = Me.TDBGrid1.Columns(5).Value & ""
            ![style] = 0
            .Update
        Else
            ![DraftID] = EMailID
            ![SendDate] = Me.TDBGrid1.Columns(2).Value
            ![SendMen] = Me.TDBGrid1.Columns(0).Value & ""
            ![Addressee] = Me.TDBGrid1.Columns(3).Value & ""
            '![CopyTo] = Me.TDBGrid1.Columns(0).Value & ""
            ![Topic] = Me.TDBGrid1.Columns(1).Value & ""
            ![KeyWord] = Me.TDBGrid1.Columns(4).Value & ""
            ![Summary] = Me.TDBGrid1.Columns(5).Value & ""
            ![style] = 0
            .Update
        
        End If
    End With
    Exit Sub
Err_SaveServerEmail:
    MisMsg "SaveServerEmail Error: " & Err.Description
    Exit Sub
End Sub

Private Sub UpdateLocalEMail(EMailID As String)
    GetCNLocal.Execute " update PubOAData set style='1' where DraftID=" & EMailID & " and SendMen='" & LoginName & "' and type=0  "
End Sub

Private Sub DelLocalEMail(EMailID As String)
    GetCNLocal.Execute " delete from PubOAData where DraftID=" & EMailID & " and SendMen='" & LoginName & "'"
End Sub


Private Sub DelServerEMail(EMailID As String)
    GetCNClient.Execute " delete from PubOAData where DraftID='" & EMailID & "'and addressee='" & LoginName & "'"
End Sub



Private Sub tcpClient_DataArrival(ByVal bytesTotal As Long)
On Error GoTo Err_tcpClient_DataArrival
   Dim strData As String
   tcpClient.GetData strData
   Me.RTxtSummary.Text = strData
   If strData <> "" Then
     Beep
     Beep
   End If
   Exit Sub
Err_tcpClient_DataArrival:
   MisMsg "tcpClient_DataArrival Error : " & Err.Description
   Exit Sub
End Sub

Private Sub ArrowLine(vLine1 As Line, vLine2 As Line, vLine3 As Line, W1 As Integer, H1 As Integer)
    Dim ArrowHigh As Integer
    Dim Mx1 As Integer, My1 As Integer
    Dim Mx As Integer, My As Integer
    On Error Resume Next
    'if vLine1.x1 - vLine1.x2 <> 0 And vLine1.Y1 - vLine1.Y2 <> 0 Then
        Mx1 = H1 * (vLine1.x1 - vLine1.x2) / Sqr((vLine1.x1 - vLine1.x2) * (vLine1.x1 - vLine1.x2) + (vLine1.Y1 - vLine1.Y2) * (vLine1.Y1 - vLine1.Y2))
        My1 = W1 * (vLine1.Y1 - vLine1.Y2) / Sqr((vLine1.x1 - vLine1.x2) * (vLine1.x1 - vLine1.x2) + (vLine1.Y1 - vLine1.Y2) * (vLine1.Y1 - vLine1.Y2))
    'End If
    vLine1.x1 = vLine1.x1 - Mx1
    vLine1.x2 = vLine1.x2 + Mx1
    vLine1.Y1 = vLine1.Y1 - My1
    vLine1.Y2 = vLine1.Y2 + My1
    ArrowHigh = 100
    vLine2.x2 = vLine1.x2
    vLine2.Y2 = vLine1.Y2
    vLine3.x2 = vLine1.x2
    vLine3.Y2 = vLine1.Y2
'--------------------------------------
    'If vLine1.x1 - vLine1.x2 <> 0 And vLine1.Y1 - vLine1.Y2 <> 0 Then
        Mx = ArrowHigh * (vLine1.x1 - vLine1.x2) / Sqr((vLine1.x1 - vLine1.x2) * (vLine1.x1 - vLine1.x2) + (vLine1.Y1 - vLine1.Y2) * (vLine1.Y1 - vLine1.Y2))
        My = ArrowHigh * (vLine1.Y1 - vLine1.Y2) / Sqr((vLine1.x1 - vLine1.x2) * (vLine1.x1 - vLine1.x2) + (vLine1.Y1 - vLine1.Y2) * (vLine1.Y1 - vLine1.Y2))
    'End If
'----------------------------------------------
'    If Me.Line1.x1 > Me.Line1.x2 And Me.Line1.Y1 > Me.Line1.Y2 Then
        vLine2.x1 = vLine1.x2 + Mx * 2 - My
        vLine2.Y1 = vLine1.Y2 + My * 2 + Mx
        vLine3.x1 = vLine1.x2 + Mx * 2 + My
        vLine3.Y1 = vLine1.Y2 + My * 2 - Mx
 '   End If
End Sub
上一页 1 2 34
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -