Distribution List Save As .txt using VBA in Outlook 2003

Question

I have several distribution lists, and each month I open each of them and save them as a .txt file, then open them in an Excel worksheet and compare them to the list in Excel.  I have never used VBA in Outlook 2003, which unfortunately doesn't have a "record macro" option.  I would like to create a macro that opens each list and saves it as a .txt file.  For instance, the distribution list names are List1, List2, etc.

Thanks for any help that can be provided!

---

taxgirl

Answer 1

It's been 6 months.   Do you still need an answer for this?

 

Answer 2

Well, I'm still doing this manually, so sure - I'd love an answer!

---

taxgirl

Answer 3

Oh - one change - I'm now using Outlook 2010.

---

taxgirl

Answer 4

sorry.  clicked the wrong choice

I have an Excel 2003 workbook that I use to send email to each member of various distr lists.  The code works its way thru the Outlook Object Model to extract the members of each list.  Would that be enough?  Can you modify it for your own use?

Or I could code something unique for you.

 

How do we get out of the forum and talk directly?

Answer 5

This does sound like something I may be able to adapt for my use.  However, I prefer to communicate only through the forum for 2 reasons - 1) privacy, and 2) all forum answers remain available for the use of others who may need them.

---

taxgirl

Answer 6

Is there a way to attach an Excel workbook, or do I have to send the source code as text

(Sorry.. I'm new to forums)

Answer 7

The following code in a Word Macro will populate a Word document with data from the Outlook Contacts
   Dim ol As Object
  Dim olns As Object
  Dim objFolder As Object
  Dim objAllContacts As Object
  Dim Contact As Object
  ' Set the Application object.
  Set ol = CreateObject("Outlook.Application")
  ' Set the Namespace object.
  Set olns = ol.GetNamespace("MAPI")
  ' Set the default Contacts folder.
  Set objFolder = olns.GetDefaultFolder(10)
  ' Set objAllContacts equal to the collection of all contacts.
  Set objAllContacts = objFolder.Items
  ' Loop through each contact.
  For Each Contact In objAllContacts
     ' Insert the data into the active document
     ActiveDocument.Range.InsertAfter Contact.FullName & vbCr & Contact.BusinessAddress & vbCr & vbCr
  Next

It uses Late Binding so it is independent of the version of Outlook

---

Hope this helps.

Doug Robbins - Word MVP,
dkr[atsymbol]mvps[dot]org
Posted via the Community Bridge

"taxgirl" wrote in message news:[e-mail]...

This does sound like something I may be able to adapt for my use. However, I prefer to communicate only through the forum for 2 reasons - 1) privacy, and 2) all forum answers remain available for the use of others who may need them.

---

taxgirl

---

Doug Robbins - Word MVP dkr[atsymbol]mvps[dot]org

Answer 8

I wish I could just send you the workbook, but...

______________________________________________________
Sheet1 should look something like this:

Enter the Group Names below, then click  [Go]  <-- this is a button named cbGo

Group Name  <-- this cell is named "Group_Name_hdr"

  <-- start entering group names here in cell A3

______________________________________________________
The code for Sheet1 is:

Private Sub cbGo_Click()
Dim objOutlook As New Outlook.Application
Dim objNamespace As Namespace
Dim objAddressList As AddressList
Dim objAddressEntry As AddressEntry
Dim wListName As String
Dim wColorIndex
Dim wGroupColorIndex
Dim wGroupRow As Long

Set objOutlook = New Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objAddressList = objNamespace.AddressLists("Global Address List")

  wRow = Range("Group_Name_hdr").Row + 1
  wOutRow = Sheet2.Range("Output_hdrs").Row + Sheet2.Range("Output_hdrs").Rows.Count
  wLastRow = Sheet2.Range("A1").SpecialCells(xlCellTypeLastCell).Row
  If wLastRow >= wOutRow Then
    Sheet2.Range( _
          Sheet2.Cells(wOutRow, 1), _
          Sheet2.Cells(wLastRow, 1) _
          ).EntireRow.Delete
  End If
  
  Do While Not IsEmpty(Cells(wRow, 1))
  
    Cells(wRow, 1).Select
    wListName = Cells(wRow, 1)
    
    With Sheet2.Cells(wOutRow, 1)
      .Formula = wListName
      .Font.Bold = True
    End With
    wGroupRow = wOutRow
    wGroupColorIndex = 54
    wOutRow = wOutRow + 1
    
    Set objAddressEntry = objAddressList.AddressEntries(wListName)
    If objAddressEntry <> wListName Then
      Sheet2.Cells(wOutRow, 2) = "-does not exist-"
      Sheet2.Cells(wOutRow, 2).Font.ColorIndex = 3
      wOutRow = wOutRow + 1
    Else
      If objAddressEntry.Members.Count = 0 Then
        Sheet2.Cells(wOutRow, 2) = "-empty-"
        wOutRow = wOutRow + 1
      Else
        For n = 1 To objAddressEntry.Members.Count
          Sheet2.Cells(wOutRow, 2) = objAddressEntry.Members(n)
          Select Case objAddressEntry.Members(n).DisplayType
           Case olUser
            Sheet2.Cells(wOutRow, 3) = "Individual"
            wColorIndex = 5
            wGroupColorIndex = xlColorIndexAutomatic
           Case olDistList
            Sheet2.Cells(wOutRow, 3) = "Group"
            wColorIndex = 54
           Case Else
            Sheet2.Cells(wOutRow, 3) = "unknown type"
            wColorIndex = 3
           End Select
          Sheet2.Range( _
            Sheet2.Cells(wOutRow, 2), _
            Sheet2.Cells(wOutRow, 3) _
            ).Font.ColorIndex = wColorIndex
          wOutRow = wOutRow + 1
        Next n
        Sheet2.Cells(wGroupRow, 1).Font.ColorIndex = wGroupColorIndex
      End If
    End If
    
    wRow = wRow + 1
  Loop
  
  Sheet2.Activate
  Sheet2.Cells(wOutRow, 2).Select
  Beep
  
Set objAddressEntry = Nothing
Set objAddressList = Nothing
Set objNamespace = Nothing
Set objOutlook = Nothing
End Sub

____________________________________________________________
Sheet2 should look like this:

One eMail will be created for each group in the list below
until a blank row is found.
The eMail will be addressed to all of the individuals;
groups will not be included.  If there are no individuals,
the eMail will not be created.

Adjust the list as needed, then click [Send eMail]  <-- this button is named cbSendEMail

or, if you wish to edit the
emails before they are sent, click [Create eMail]  <-- this button is named cbCreateEmails

Group Name                                                                        }  this range (A5..D6)
    Member Name         Type          Response        }  is named Output_hdrs

____________________________________________________________
The code for Sheet2 is:

Dim objOL As New Outlook.Application
Dim mSend As Boolean

Private Sub cbCreateEmails_Click()

  mSend = False
  Call CommonProcess

End Sub

Private Sub cbSendEMail_Click()

  mSend = True
  Call CommonProcess

End Sub

Sub CommonProcess()
Dim wRow As Long
Dim wGroupRow As Long
Dim wGroupName As String
Dim wMailItem As Outlook.MailItem

  Set objOL = New Outlook.Application

  wRow = Range("Output_hdrs").Row + Range("Output_hdrs").Rows.Count
  
  Do While Not (IsEmpty(Cells(wRow, 1)) And IsEmpty(Cells(wRow, 2)))
  
    If Not IsEmpty(Cells(wRow, 1)) Then
      Cells(wRow, 1).Select
      wGroupName = Cells(wRow, 1)
      Set wMailItem = CreateEmail(wGroupName)
      wGroupRow = wRow
      wRow = wRow + 1
      Do While Not IsEmpty(Cells(wRow, 2))
        If Cells(wRow, 3) = "Individual" Then
          wMailItem.Recipients.Add Cells(wRow, 2)
        End If
        wRow = wRow + 1
      Loop
      If wMailItem.Recipients.Count > 0 Then
        If mSend Then
          wMailItem.Send
          Cells(wGroupRow, 4) = "sent"
        Else
          wMailItem.Display
          Cells(wGroupRow, 4) = "created"
        End If
      Else
        wMailItem.Delete
        Cells(wGroupRow, 4) = "skipped"
      End If
    End If
    
  Loop

  Set wMailItem = Nothing
  Set objOL = Nothing
End Sub
Function CreateEmail(aGroupName As String) As Outlook.MailItem
Dim wMailItem As MailItem

  Set wMailItem = objOL.CreateItem(olMailItem)

  With wMailItem
    .HTMLBody _
      = "<font face=""Arial"" size=""2"">" _
      + "You are receiving this email because you are a member<br>" _
      + "of group <strong>" + aGroupName + "</strong><br>" _
      + "<br>" _
      + "Please respond by choosing one of the voting buttons..<br>" _
      + "<br>" _
      + "If you wish to continue to receive emails as part of this group, choose [Yes, Continue]<br>" _
      + "If you wish to be removed from this group, and not receive any more emails, choose [No, Stop]" _
      + "</font>"
    .Importance = olImportanceNormal
    .Subject = "eMail Group Review: " + aGroupName
    .VotingOptions = "YES, Continue;NO, Stop"
  End With
  
  Set CreateEmail = wMailItem
End Function

Let me know if you have any problems.  Dan

Answer 9

Hi Dan,

I created a new module in a new worksheet, and set up the 2 sheets.  I copied the first code into the new module, and when I run this macro, it doesn't get past the first line:

Dim objOutlook As New Outlook.Application

So, I tried typing in the line, and after As New, Outlook is not one of the available options.  If I do the same thing in a VBA macro in Outlook, then Outlook.Application is valid, but not in Excel.

Am I missing something?

Thanks!

---

taxgirl

Answer 10

Hi Doug,

I tried creating a Word macro and copying in the code you suggested.  When the macro got to the line

 Set ol = CreateObject("Outlook.Application")

I got the error "Run-time error '429':  activeX component can't create object.

Thanks!

---

taxgirl

Answer 11

Works fine here, whether Outlook is running or not.  However try it both ways.

---

Hope this helps.

Doug Robbins - Word MVP,
dkr[atsymbol]mvps[dot]org
Posted via the Community Bridge

"taxgirl" wrote in message news:[e-mail]...

Hi Doug,

I tried creating a Word macro and copying in the code you suggested.  When the macro got to the line

 Set ol = CreateObject("Outlook.Application")

I got the error "Run-time error '429':  activeX component can't create object.

Thanks!

---

taxgirl

---

Doug Robbins - Word MVP dkr[atsymbol]mvps[dot]org

Answer 12

sorry.  I forget little things.. 

You need the Outlook Object Library

In the Visual Basic window,  Drop the Tools menu, and choose References..

Find and check "Microsoft Outlook vv.m Object Library", and click [OK]

Answer 13

Thanks - it got a little farther this time!  However, at the line

Set objAddressList = objNamespace.AddressLists("Global Address List")

I got the error "Method 'AddressLists' of object'_NameSpace' failed'

---

taxgirl

Answer 14

Hi Doug,

It didn't make any difference whether I had Outlook open or closed.  However, after I went into Tools References to tick the Outlook 14.0 Object Library, then changed that line to read

  Set ol = New Outlook.Application

the macro got all the way to the last line,

     ActiveDocument.Range.InsertAfter Contact.FullName & vbCr & Contact.BusinessAddress & vbCr & vbCr

where it stopped, with the message Run-time error '438':

Object doesn't support this property or method.
I tried changing the last line to

  ActiveDocument.Range.InsertAfter (vbCr)

and the macro worked, but provided me a document with some names and some e-mail addresses, and some address parts.

Is there a way to change this macro so it will go through each "contact group", and provide a list that shows the contact group name and the e-mail address?  Or, the contact group name and the "display name" (which includes the e-mail address)?

Thanks!

---

taxgirl

Answer 15

I'm guessing that "Global Address List" is not an AddressList at your installation.  You will have to find out what is your equivalent.

 

Put a stop on that line of code.  Add a watch on objNamespace.AddressLists.
Execute the code.  When it stops, examine the Items properties; one of them should be named something obvious; try using that.