Outlook VBA OTM Bcc based on group membership

I've been tasked with modifying an outlook OTM file that currently ask the users a question when sending mail

The OTM file asks the users if they would like to send a copy of the mail there sending to a predefined mailbox (BCC)

What I need to do is change the script so it reads group membership of the user and based on the group membership gives them a drop down box. this drop down will give them a choice of mailboxes to BCC the mail to.
for example

If user A is a member of group Domain\projectA and domain\ProjectB then the dropdown would give the user the drop down box when sending a mail to choose between the projectA and Project B mailboxes for Bcc.

Is the above possible?

the current OTMfile has the below code in it.



I hope this is possible

Thanks chris

Code:

---

Sub DateStamp()
'by simon rickell
  Dim objApp As Application
  Dim objItems As Object
  Dim objItem As Object
  Dim objNS As NameSpace
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objItems = objApp.ActiveExplorer.Selection
  For Each objItem In objItems
  If objItem.Class = olMail Then
    If Left$(objItem.Subject, Len(objItem.SentOn)) <> Format(objItem.SentOn, "YYYY-MM-DD HH:MM:SS") Then
   
      objItem.Subject = Format(objItem.SentOn, "YYYY-MM-DD HH:MM:SS") & "-" & objItem.Subject
      objItem.Save
    End If
  End If
 
  Next
 
 
  Set objItem = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Sub

Sub Create_Button()
    Dim cbTesting As CommandBar
    Dim ctlCBarButton As CommandBarButton
    Dim ctlCBarCombo As CommandBarComboBox
    Dim ctlCBarPopup As CommandBarPopup
    On Error Resume Next
    Set cbTesting = Application.ActiveExplorer.CommandBars("Shepherd")
    If Err = 0 Then
        cbTesting.Delete
    End If
    Set cbTesting = Application.ActiveExplorer.CommandBars _
        .Add(Name:="Shepherd", Position:=msoBarTop)
    Set ctlCBarButton = cbTesting.Controls.Add(Type:=msoControlButton)
    With ctlCBarButton
        .Caption = "Date Stamp"
        .FaceId = 2167
        .Style = msoButtonCaption
        .Visible = True
        .OnAction = "Project1.ThisOutlookSession.DateStamp"
        .TooltipText = "Date stamp an item of mail with the received date"
    End With
    cbTesting.Visible = True
End Sub
 
Sub CCProjMail()
'by Allan Scott
Sub Application_ItemSend(ByVal MailItem As Object, Cancel As Boolean)
    Dim projMail As String
    Dim ask As String
    ask = MsgBox("Send a copy to 'Computer Helpdesk' Project Mail Box?", _
    vbYesNo + vbQuestion, "Project eMail")
    If ask = vbNo Then
    'Resolve the address
    MailItem.Recipients.ResolveAll
    MsgBox ("Your email will be sent as normal"), vbOKOnly + vbInformation
    Else: ask = vbYes
    projMail = ("")
    MailItem.CC = MailItem.CC & ";" & projMail
    'Resolve the address
    MailItem.Recipients.ResolveAll
    MsgBox ("Your email will be sent with a copy sent to 'Computer Helpdesk' Project Mail Box"), _
    vbOKOnly + vbInformation
   
End If
End Sub

---

Appears the only relevant code is Application_ItemSend.

Code:

---

Sub Application_ItemSend(ByVal MailItem As Object, Cancel As Boolean)
        Dim projMail As String
        Dim ask As String
        ask = MsgBox("Send a copy to 'Computer Helpdesk' Project Mail Box?", _
        vbYesNo + vbQuestion, "Project eMail")
        If ask = vbNo Then
            'Resolve the address
            MailItem.Recipients.ResolveAll
            MsgBox ("Your email will be sent as normal"), vbOKOnly + vbInformation
        Else: ask = vbYes
            projMail = ("")
            MailItem.CC = MailItem.CC & ";" & projMail
            'Resolve the address
            MailItem.Recipients.ResolveAll
            MsgBox ("Your email will be sent with a copy sent to 'Computer Helpdesk' Project Mail Box"), _
            vbOKOnly + vbInformation
           
        End If
    End Sub

---

I suggest you will start Application_ItemSend from scratch.

I do not think you can get to "Member Of" information with VBA. If true, you will have to know the group and check all the members to see if the sender is included. To check for membership in groups. http://www.slipstick.com/developer/c...e-gal-members/

This code is slow. It will be high maintenance having to be updated with every new project.

Code:

---

Sub GetDGMembers()
 
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntry
Dim olMember As Outlook.AddressEntry
Dim lMemberCount As Long
Dim objMail As Outlook.MailItem
 
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olAL = olNS.AddressLists("Global Address List")
 
Set objMail = olApp.CreateItem(olMailItem)
 
' enter the list name
Set olEntry = olAL.AddressEntries("Advertiser Inquiries")
 
' get count of dist list members
lMemberCount = olEntry.Members.Count
 
' loop through dist list and extract members
Dim i As Long
For i = 1 To lMemberCount
  Set olMember = olEntry.Members.Item(i)
  strName = olMember.Name
  strAddress = olMember.GetExchangeUser.PrimarySmtpAddress
  strPhone = olMember.GetExchangeUser.BusinessTelephoneNumber
 
  objMail.Body = objMail.Body & strName & " -- " & strAddress & " -- " & strPhone & vbCrLf
Next i
 
objMail.Display
 
End Sub

---

Each sender will need a userform.

This describes a userform with a list. http://www.vbaexpress.com/kb/getarticle.php?kb_id=303 You will likely want to fill the list with applicable project addresses rather than a static set of addresses.

This demonstrates how to pass an address back to a mailitem. http://www.vbaexpress.com/forum/show...It-stays-empty