modmailmenu.bas

智能邮件管理信息系统

Attribute VB_Name = "ModMailMenu"
Option Explicit

Public Sub pCreateMailMenu(lnghwndOwner As Long, x As Long, y As Long)
    
    Dim strsql As String
    Dim strsql1 As String
    Dim LngEmployeeID As Long
    Dim strEmployeeID As String
    Dim strCustomerID As String
    Dim LngCustomerID As Long
    Dim lngCustomerCounter As Long
    Dim m_MailType As MailDll.MailType
    Dim mCustomer As PCustomer.Customer
    Dim mCustomers As PCustomer.Customers
    Dim mSystemMenus As PSystemMenu.SystemMenus
    Dim mSystemMenu As PSystemMenu.SystemMenu
    Dim m_MailTemplate As PMailTemplate.MailTemplate
    
    Dim mclsMailCreator1 As MailDll.Mail
    Set mclsMailCreator1 = GetMailCls
    GetMailSimple frmMain.ctlMailList.mlngCurrentSelectID, m_MailType, mclsMailCreator1
    
    Dim mZhuanFaEmployees As PEmployee.Employees
    
    Dim mclsCustomer1 As PCustomer.clsCustomer
    Set mclsCustomer1 = GetclsCustomer
    Dim mclsEmployee As New PEmployee.clsEmployee
    mclsEmployee.Init gdbCurrentDB
    Dim mEmployees As PEmployee.Employees
    
    


    '********************************************************************************
    '邮件分发处理
   '"email地址匹配"规则：根据“发件人”email地址到联系人表中找到该信是哪个客户发来的，找到后，就把该客户对应的
   '职员的lngContactID存到mail表的lngContactID.这时该邮件就有了归属人?
   ' 还有考虑到一些特殊情况的分支处理，比如，找不到匹配的客户怎么办？ 有多个客户具有相同的email地址怎么办？
    '此处匹配邮件地址(客户中)
    If InStr(1, UCase(gdbCurrentDB.ConnectionString), UCase("Microsoft Access Driver")) > 0 Then
        strsql = "select * FROM Customer where ucase(strEmail)='" & UCase(Trim(m_MailType.StrReceiverString)) & "'"
    Else
        strsql = "select * FROM Customer where UPPER(strEmail)='" & UCase(Trim(m_MailType.StrReceiverString)) & "'"
    End If
    
    mclsCustomer1.GetCustomers strsql, mCustomers
    
        
    '转发给职员的列表
    strsql1 = "select * from Employee"
    mclsEmployee.GetEmployees strsql1, mZhuanFaEmployees
    strCustomerID = ""
    
    '可能的客户ID列表
    If mCustomers.Count > 0 Then
        For lngCustomerCounter = 0 To mCustomers.Count - 1
            LngCustomerID = mCustomers.Customer(lngCustomerCounter).LngCustomerID
            strCustomerID = strCustomerID & LngCustomerID & ","
        Next lngCustomerCounter

        If Trim(strCustomerID) <> "" Then
            If Right(strCustomerID, 1) = "," Then
                strCustomerID = left(strCustomerID, Len(strCustomerID) - 1)
                strCustomerID = "(" & strCustomerID & ")"
            Else
                strCustomerID = "(" & strCustomerID & ")"
            End If
        End If

        '根据客户找到对应的职员列表ID
        If Trim(strCustomerID) <> "" Then
            strsql = "select * from Customer where lngCustomerID in " & strCustomerID
        Else
            strsql = "select * from Customer "
        End If
        
        Dim i As Long
        mclsCustomer1.GetCustomers strsql, mCustomers
        If mCustomers.Count > 0 Then
            For i = 0 To mCustomers.Count
                LSet mCustomer = mCustomers.Customer(i)
                If mCustomer.LngEmployeeID > 0 Then
                    LngEmployeeID = mCustomer.LngEmployeeID
                    strEmployeeID = strEmployeeID & LngEmployeeID & ","
                End If
            Next i
        End If
        
        If Trim(strEmployeeID) <> "" Then
            If Right(strEmployeeID, 1) = "," Then
                strEmployeeID = left(strEmployeeID, Len(strEmployeeID) - 1)
                strEmployeeID = "(" & strEmployeeID & ")"
            Else
                strEmployeeID = "(" & strEmployeeID & ")"
            End If
        End If

        '根据对应的可能的职员,加载菜单
        If Trim(strEmployeeID) <> "" Then
            strsql = "select * FROM Employee where lngEmployeeID in " & strEmployeeID
        Else
            strsql = "select * FROM Employee "
        End If
    End If
    mclsEmployee.GetEmployees strsql, mEmployees
    '手工分发的功能现在看不到了。是不是"内部分发选择邮件"，但点了后没有什么反应。
    '如果分发中没有任何匹配职员，列出所有职员作为分发对象
    If mEmployees.Count = 0 Then
        strsql = "Select * From Employee"
        mclsEmployee.GetEmployees strsql, mEmployees
    End If
    '********************************************************************************


    '********************************************************************************
    '邮件归并

    '********************************************************************************
    
    Dim lngMenuCounter As Long
    Dim STRSQ As String
    
    Dim mclsSystemMenu As New clsSystemMenu
    mclsSystemMenu.Init gdbCurrentDB
    Dim mEmployee As PEmployee.Employee


    Set frmMain.mnuPopMenu = New XpPopMenu.cPopupMenu

    With frmMain.mnuPopMenu
        '在什么组件上显示出来(以那个组件为弹出坐标参照）
'        .ImageList = imgNormal
        .OfficeXpStyle = True
        .MenuBackgroundColor = -1
        .InActiveMenuForeColor = -1
        .ActiveMenuForeColor = -1
        .ActiveMenuBackgroundColor = -1
        .Font = Nothing
        .BackgroundPicture = Nothing
        .HeaderStyle = XpPopMenu.ecnmHeaderSeparator

        .HideInfrequentlyUsed = True
        .OfficeXpStyle = False
        Dim blnSelectMail As Boolean
        blnSelectMail = (frmMain.ctlMailList.mlngCurrentSelectID > 0)


        .ClearMenuItems
        .hwndOwner = lnghwndOwner
        .ImageList = frmMain.m_CImageListHot.hIml
'
'
        #If ChengRen = 1 Then
            If m_E_ViewMode = m_ServerMode Then
                strsql = "select * from SystemMenu Where strMenuName='mnuPopMenuChengRenSever' order by intorder"
            Else
                strsql = "select * from SystemMenu Where strMenuName='mnuPopMenuChengRen' order by intorder"
            End If
        #ElseIf V98989 = 1 Then
            If m_E_ViewMode = m_ServerMode Then
                strsql = "select * from SystemMenu Where strMenuName='mnuPopMenu98989Sever' order by intorder"
            Else
                strsql = "select * from SystemMenu Where strMenuName='mnuPopMenu98989' order by intorder"
            End If
        #ElseIf OneUser = 1 Then
            If m_E_ViewMode = m_ServerMode Then
                strsql = "select * from SystemMenu Where strMenuName='mnuOneUserPopMenuSever' order by intorder"
            Else
                strsql = "select * from SystemMenu Where strMenuName='mnuOneUserPopMenu' order by intorder"
            End If
        #Else
            If m_E_ViewMode = m_ServerMode Then
                strsql = "select * from SystemMenu Where strMenuName='mnuPopMenuSever' order by intorder"
            Else
                strsql = "select * from SystemMenu Where strMenuName='mnuPopMenu' order by intorder"
            End If
        #End If
         
        mclsSystemMenu.GetSystemMenus strsql, mSystemMenus
        If mSystemMenus.Count > 0 Then
            For lngMenuCounter = 0 To mSystemMenus.Count
                LSet mSystemMenu = mSystemMenus.SystemMenu(lngMenuCounter)
                If mSystemMenu.lngSystemMenuID > 0 Then
                    .AddMenuItem mSystemMenu.sKey, IIf(BlnEnglishVersion, mSystemMenu.sEnglishCaption, mSystemMenu.sCaption), mSystemMenu.strParenetKey, mSystemMenu.sHelptext, mSystemMenu.lItemData, mSystemMenu.iIconIndex, mSystemMenu.bChecked, blnSelectMail, mSystemMenu.bVisable
                End If
            Next lngMenuCounter
        End If
        
        
    
        If mEmployees.Count > 0 Then
            For i = 0 To mEmployees.Count - 1
                LSet mEmployee = mEmployees.Employee(i)
                .AddMenuItem "SendToOtherFen" & mEmployee.LngEmployeeID, mEmployee.strEmployeeName & "(" & mEmployee.strEmail & ")", "SendToOtherFen", , 10, , , blnSelectMail And (m_E_TreeViewType = m_OutlookTreeView)
            Next i
        End If

        
        '内部转发没有必要列出当前职员自己，而且当我转发给自己后，虽然看到有两封未读的邮件，但在左边的树形菜单中只显示了一封未读。重新登陆后，显示为两封。
        If mZhuanFaEmployees.Count > 0 Then
            For i = 0 To mZhuanFaEmployees.Count - 1
                LSet mEmployee = mZhuanFaEmployees.Employee(i)
'                If m_E_ViewMode = m_CliendMode Then '一般职员
                    If mEmployee.LngEmployeeID <> gLngEmployeeID1 Then
                        .AddMenuItem "SendToOtherZhuan" & mEmployee.LngEmployeeID, mEmployee.strEmployeeName & "(" & mEmployee.strEmail & ")", "SendToOtherZhuan", , 100, , , blnSelectMail
                    End If
'                End If
            Next i
        End If
            
            
        '如果是发件箱,修改打开邮件为 新增邮件
        If frmMain.ctlMailList.mlngViewID = 3 Then
            .MenuItemCaption("OpenMail") = "新建邮件"
            .MenuItemEnabled("OpenMail") = True
        End If
        
        
        
        '再次发送(&R)
        .MenuItemEnabled("ReSend") = (frmMain.ctlMailList.mlngViewID = 4)
        '回复
        .MenuItemEnabled("ReSender") = (blnSelectMail) And (frmMain.ctlMailList.mlngViewID = 2)
        '全部回复(&A)
        .MenuItemEnabled("ReAllMail") = (blnSelectMail) And (frmMain.ctlMailList.mlngViewID = 2)
        '转发(&F)
        .MenuItemEnabled("ResendMail") = (blnSelectMail)
        '作为附件转发(&W)
        .MenuItemEnabled("ResendAsFJ") = (blnSelectMail)
        
        .MenuItemEnabled("SendToOtherFenAll") = frmMain.ctlMailList.mlngViewID = 2
        .MenuItemEnabled("SendToOtherFen") = blnSelectMail And frmMain.ctlMailList.mlngViewID = 2