none
Extract Recipients Names to Excel RRS feed

  • Question

  • I found some VBA that claims that it will extract the recipient's e-mail address and put it in an Exce sheet.  However, I don't see where in the code you can select the location you want it sent to?  Also, when I use the debugger, it says that "user-defined type not defined" and highlights the line that reads "Dim c as Range".  Does anyone know how I can get this to work?  Is there a better way to go about doing this?

    Sub GetAddresses()
       Dim o, AddressList, AddressEntry
       Dim c As Range, r As Range, AddressName As String
       Set o = GetObject(, "Outlook.Application")
       
       Set AddressList = o.Session.AddressLists("Global Address List")
       Set r = Range("A1:A2")
       For Each c In r
           AddressName = c.Value
           For Each AddressEntry In AddressList.AddressEntries
               If AddressEntry.Name = AddressName Then
                   c.Offset(0, 1).Value = AddressEntry.Address
                   Exit For
               End If
           Next AddressEntry
       Next c
    End Sub

    Wednesday, March 28, 2012 5:49 PM

Answers

  • I botched the editing of that code, let's try this again. Just bear in mind that the address that will be put into Excel is an Exchange address if the sender is someone from your own Exchange GAL (if you're using Exchange).
     
    Public Sub StripAttachments()
        Dim objOL As Outlook.Application
        Dim objMsg As Object
        Dim objAttachments As Outlook.Attachments
        Dim objSelection As Outlook.Selection
        Dim i As Long
        Dim lngCount As Long
        Dim strFile As String
        Dim strFolder As String
     
        On Error Resume Next
     
        ' Instantiate an Outlook Application object.
        Set objOL = Application
        ' Get the collection of selected objects.
        Set objSelection = objOL.ActiveExplorer.Selection
     
        ' Get the Temp folder.
        strFolder = "C:\MY DOCUMENTS\New Change Orders\"
           
        ' Check each selected item for attachments.
        ' If attachments exist, save them to the Temp
        ' folder and strip them from the item.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
                OutlookRecipsToExcel objMsg
     
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.count
                If lngCount > 0 Then
                    ' We need to use a count down loop for
                    ' removing items from a collection. Otherwise,
                    ' the loop counter gets confused and only every
                    ' other item is removed.
                    For i = lngCount To 1 Step -1
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        strFile = objAttachments.Item(i).FileName
                        ' Combine with the path to the Temp folder.
                        strFile = strFolder & strFile
                        ' Save the attachment as a file.
                        objAttachments.Item(i).SaveAsFile strFile
                        ' Delete the attachment.
                        objAttachments.Item(i).Delete
                    Next i
                End If
                objMsg.Save
            End If
        Next
     
    ExitSub:
        Set objAttachments = Nothing
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
    End Sub
     

    Public Sub OutlookRecipsToExcel(oMail As Outlook.MailItem)
      'Excel definitions
      Dim oExcel As Excel.Application
      Dim oRange As Excel.Range
      Dim oSheet As Excel.Worksheet
      'Number of sheets in new WorkBook
      Dim lSheets As Long
     
      'Outlook definitions
      Dim oRecips As Outlook.Recipients
      Dim oRecip As Outlook.Recipient
     
      Dim sRange As String
      Dim sCol As String
      Dim iRow As Integer
     
      'Initialize Outlook items
      Set oRecips = oMail.Recipients
     
      'Get an Excel Application object
      'Set oExcel = GetObject(, "Excel.Application")
      'If oExcel Is Nothing Then
        Set oExcel = CreateObject("Excel.Application")
      'End If
     
      'Initialize Excel items
      'Save the previous setting for the number of Sheets
      'in a new WorkBook
      lSheets = oExcel.SheetsInNewWorkbook
      'Only 1 sheet in this WorkBook
      oExcel.SheetsInNewWorkbook = 1
      'Create a new WorkBook and make it active
      oExcel.Workbooks.Add
      'Activate Sheet 1
      Set oSheet = oExcel.ActiveWorkbook.Sheets(1)
      oSheet.Activate
      oExcel.Visible = True
     
      'Column A, Row 1 Sheet Title - Bold, 14 pt, underlined
      Set oRange = oSheet.Range("A1")
     
      'Start adding data at Column A, Row 3
      iRow = 2 'this number will be incremented in the For Each loop
     
      For Each oRecip In oRecips
        If oRecip.Type = olTo Then
            sCol = "A"
            sCol = Chr(Asc(sCol) - 1)
            'Start a new data Row
            iRow = iRow + 1
           
            With oRecip
                SetRangeData oSheet, sCol, iRow, ..name
                SetRangeData oSheet, sCol, iRow, ..Address
                SetRangeData oSheet, sCol, iRow, oMail.Subject
            End With
        End If
      Next oRecip
     
      'Set a Range covering all the data in the Sheet
      sRange = "A3:" & sRange
     
      'AutoFit the Columns
      oSheet.Range(sRange).Columns.AutoFit
      'AutoFit the Rows
      oSheet.Range(sRange).rows.AutoFit
     
      'Restore the old setting for number of Sheets
      'in a new WorkBook
      oExcel.SheetsInNewWorkbook = lSheets
     
      Set oSheet = Nothing
      Set oRange = Nothing
      Set oExcel = Nothing
      Set oRecip = Nothing
      Set oRecips = Nothing
    End Sub
     
    Private Sub SetRangeData(oSheet As Excel.Worksheet, sCol As String, _
            iRow As Integer, sValue As String)
      Dim oRange As Excel.Range
      Dim sRange As String
     
      sCol = Chr(Asc(sCol) + 1)
      sRange = sCol & CStr(iRow)
      Set oRange = oSheet.Range(sRange)
      oRange.Value = sValue
     
      Set oRange = Nothing
    End Sub

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:1ea4fee0-54b6-4a70-8378-6e802fd7b2c1...

    Okay, I took those lines out and ran the code.  I did not get any error messages, however, I also did not get any results with the recipient name.

    I just had a thought, would it be easier to pull the recipient name and just tack it on to the name of the attachment (i.e. attachment name - "ChangeOrder for Drucker's Store.pdf" - could it change to "Joe Smith ChangeOrder for Drucker's Store.pdf"or even "Joe.Smith@mail.com ChangeOrder for Drucker's Store.pdf")?  If it could be done that way, I wouldn't need the subject line.  What do you think?  Would that be easier?


    Ken Slovak MVP - Outlook
    Thursday, March 29, 2012 9:25 PM
    Moderator

All replies

  • You need to add a project reference to Excel. In the VBA project click on Tools, References and add a reference to Excel.
     
    Where the data goes is set by the initial Range - A1:A2. Then a Range.Offset is applied of (0,1). Change those if you want the data to go elsewhere.

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:24943d20-5231-481d-8200-67c98d81951c...

    I found some VBA that claims that it will extract the recipient's e-mail address and put it in an Exce sheet.  However, I don't see where in the code you can select the location you want it sent to?  Also, when I use the debugger, it says that "user-defined type not defined" and highlights the line that reads "Dim c as Range".  Does anyone know how I can get this to work?  Is there a better way to go about doing this?

    Sub GetAddresses()
       Dim o, AddressList, AddressEntry
       Dim c As Range, r As Range, AddressName As String
       Set o = GetObject(, "Outlook.Application")
       
       Set AddressList = o.Session.AddressLists("Global Address List")
       Set r = Range("A1:A2")
       For Each c In r
           AddressName = c.Value
           For Each AddressEntry In AddressList.AddressEntries
               If AddressEntry.Name = AddressName Then
                   c.Offset(0, 1).Value = AddressEntry.Address
                   Exit For
               End If
           Next AddressEntry
       Next c
    End Sub


    Ken Slovak MVP - Outlook
    Wednesday, March 28, 2012 6:07 PM
    Moderator
  • I added the reference to Excel, and now I am getting a different error message.  It says "Run-time error '1004':  Method 'Range' of object'_Global' failed".  When I click on the Debug button, it highlights the line that reads "Set r = Range("A1:A2")".  What does that mean?  How can I fix it?
    Wednesday, March 28, 2012 6:58 PM
  • The code looks like it's designed to work inside the Excel VBA project. If you are running this inside the Outlook VBA project you would need to open Excel, open a worksheet, and then Range should work if it references the sheet.

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:5f606d15-bd97-406d-a041-5bf5cdecf72b...
    I added the reference to Excel, and now I am getting a different error message.  It says "Run-time error '1004':  Method 'Range' of object'_Global' failed".  When I click on the Debug button, it highlights the line that reads "Set r = Range("A1:A2")".  What does that mean?  How can I fix it?

    Ken Slovak MVP - Outlook
    Wednesday, March 28, 2012 7:23 PM
    Moderator
  • Okay, I moved this code over to Excel and ran it.  It ran without giving me any error messages, but I also did not see any results.  Is there a better way to get this information?  If possible, I would also like to extract the subject line at the same time.
    Wednesday, March 28, 2012 7:47 PM
  • In looking at what that code does, it first gets the Exchange Global Address List. Are you on Exchange server?
     
    Then, it assumes the worksheet is an existing sheet that has address entry names from the Exchange GAL in column A of the sheet. Unless there's an existing name in that location in the sheet the value of AddressName will always be "" and there no entries will ever be added to the sheet. If it finds a matching entry it then adds the email address next to the name.
     
    When you mentioned Subjects were you under the impression that the code had anything to do with emails? It has nothing to do with emails.
     
    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:01af123b-2784-4d0d-a861-4271fa611bac...
    Okay, I moved this code over to Excel and ran it.  It ran without giving me any error messages, but I also did not see any results.  Is there a better way to get this information?  If possible, I would also like to extract the subject line at the same time.

    Ken Slovak MVP - Outlook
    Wednesday, March 28, 2012 8:07 PM
    Moderator
  • I was under the impression that this would extract the recipients e-mail address.  I found the code on OutlookCode.com when I searched for extracting e-mail addresses.  I need something that will tell me the recipients e-mail or name and if possible the subject line. 

    I am working on a project where I will be copied on every e-mail a salesman sends to an order entry person for a change to an order.  I found code on OutlookCode.com to strip the attachment off the e-mail and save it in a folder on my harddrive.  However, the attachment does not show the name of the person who originally recieved the e-mail.  I need to know the person's name, so that I can load the correct information in a database.  I would like to extract the subject line, because the subject line is usually the same as the attachment.  This would allow me to link the recipient with the appropriate change order.

    Wednesday, March 28, 2012 8:20 PM
  • So do you just need the email addresses of any recipients aside from you, plus the subject of an email you already have a reference to?
     
    Do you need to put the data into Excel, or was that a red herring?
     
    What do you want if there are more than 1 recipient?
     
    Are you getting copies of the email as a Bcc?
     
    Do you want all recipients (To, Cc, Bcc) or only some?

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:58bda11e-ec75-40aa-a1b9-a2b17423d6e5...

    I was under the impression that this would extract the recipients e-mail address.  I found the code on OutlookCode.com when I searched for extracting e-mail addresses.  I need something that will tell me the recipients e-mail or name and if possible the subject line. 

    I am working on a project where I will be copied on every e-mail a salesman sends to an order entry person for a change to an order.  I found code on OutlookCode.com to strip the attachment off the e-mail and save it in a folder on my harddrive.  However, the attachment does not show the name of the person who originally recieved the e-mail.  I need to know the person's name, so that I can load the correct information in a database.  I would like to extract the subject line, because the subject line is usually the same as the attachment.  This would allow me to link the recipient with the appropriate change order.


    Ken Slovak MVP - Outlook
    Wednesday, March 28, 2012 8:38 PM
    Moderator
  • I only need to see the recipient in the To Line (my name will normally be in the BCC line).  There should normally just be one name on that line, but if there is more than one, I would need to see all of them.  Yes, I would like to see the Subject Line.  You are correct, too, I would like to have this information put in Excel, if at all possible.  That way, I can use a vlookup to link the recipient's name with the right attachment.
    Wednesday, March 28, 2012 8:55 PM
  • Something like this is more what you would need. It's set up to run from the Outlook VBA project. Call it with the mail item as the argument.
     
    Public Sub OutlookRecipsToExcel(oMail As Outlook.MailItem)
      'Excel definitions
      Dim oExcel As Excel.Application
      Dim oRange As Excel.Range
      Dim oSheet As Excel.Worksheet
      'Number of sheets in new WorkBook
      Dim lSheets As Long
     
      'Outlook definitions
      Dim oRecips As Outlook.Items
      Dim oRecip As Outlook.ContactItem
      Dim sRange As String
      Dim sCol As String
      Dim iRow As Integer
     
      'Initialize Outlook items
      Set oRecips = oMail.Recipients
     
      'Get an Excel Application object
      Set oExcel = GetObject(, "Excel.Application")
      If oExcel Is Nothing Then
        Set oExcel = CreateObject("Excel.Application")
      End If
      
      'Initialize Excel items
      'Save the previous setting for the number of Sheets
      'in a new WorkBook
      lSheets = oExcel.SheetsInNewWorkbook
      'Only 1 sheet in this WorkBook
      oExcel.SheetsInNewWorkbook = 1
      'Create a new WorkBook and make it active
      oExcel.Workbooks.Add
      'Activate Sheet 1
      Set oSheet = oExcel.ActiveWorkbook.Sheets(1)
      oSheet.Activate
      oExcel.Visible = True
     
      'Column A, Row 1 Sheet Title - Bold, 14 pt, underlined
      Set oRange = oSheet.Range("A1")
      SetSheetHeadings oRange, "Outlook Contacts", True, 14, _
        xlHairline, xlLineStyleNone, xlUnderlineStyleSingle
     
      'Start adding data at Column A, Row 3
      iRow = 2 'this number will be incremented in the For Each loop
     
      For Each oRecip In oRecips
        If oRecip.Type = olTo Then
            sCol = "A"
            sCol = Chr(Asc(sCol) - 1)
            'Start a new data Row
            iRow = iRow + 1
            
            With oRecipient
                SetRangeData oSheet, sCol, iRow, .Name
                SetRangeData oSheet, sCol, iRow, ..Address
                SetRangeData oSheet, sCol, iRow, oMail.Subject
            End With
        End If
      Next oRecip
      
      'Set a Range covering all the data in the Sheet
      sRange = "A3:" & sRange
     
      'AutoFit the Columns
      oSheet.Range(sRange).Columns.AutoFit
      'AutoFit the Rows
      oSheet.Range(sRange).rows.AutoFit
     
      'Restore the old setting for number of Sheets
      'in a new WorkBook
      oExcel.SheetsInNewWorkbook = lSheets
      
      Set oSheet = Nothing
      Set oRange = Nothing
      Set oExcel = Nothing
      Set oContact = Nothing
      Set oItem = Nothing
      Set oItems = Nothing
      Set oFolder = Nothing
      Set oNS = Nothing
      Set oOutlook = Nothing
    End Sub
     
    Private Sub SetRangeData(oSheet As Excel.Worksheet, sCol As String, _
            iRow As Integer, sValue As String)
      Dim oRange As Excel.Range
      Dim sRange As String
     
      sCol = Chr(Asc(sCol) + 1)
      sRange = sCol & CStr(iRow)
      Set oRange = oSheet.Range(sRange)
      oRange.Value = sValue
     
      Set oRange = Nothing
    End Sub

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:327c86f9-31e1-47d1-a021-57d375a9c3c5...
    I only need to see the recipient in the To Line (my name will normally be in the BCC line).  There should normally just be one name on that line, but if there is more than one, I would need to see all of them.  Yes, I would like to see the Subject Line.  You are correct, too, I would like to have this information put in Excel, if at all possible.  That way, I can use a vlookup to link the recipient's name with the right attachment.

    Ken Slovak MVP - Outlook
    • Proposed as answer by VBAToolsMVP Thursday, March 29, 2012 1:09 PM
    Wednesday, March 28, 2012 9:45 PM
    Moderator
  • Thank you very much for the code.  I really appreciate it.  I just have one question.  What do you mean when you say to "call it with mail item as the argument"?  How do I do that?  I apologize for my ignorance.  I have worked with vba in Access and Excel, but I've never worked with it in Outlook until yesterday, so I'm not real sure how to call it. 
    Thursday, March 29, 2012 12:17 PM
  • You say you already have code that saves the attachments from a mail item to the file system. For that to work you must have a reference to a mail item. Use that reference and pass it to the procedure I supplied.

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:0ba6d8d9-662a-45d6-ab3c-c4d1af7b8170...
    Thank you very much for the code.  I really appreciate it.  I just have one question.  What do you mean when you say to "call it with mail item as the argument"?  How do I do that?  I apologize for my ignorance.  I have worked with vba in Access and Excel, but I've never worked with it in Outlook until yesterday, so I'm not real sure how to call it. 

    Ken Slovak MVP - Outlook
    Thursday, March 29, 2012 1:05 PM
    Moderator
  • This is what I have, is this how it should look?  I just added the code you provided after the code I already had.

    Public Sub StripAttachments()
        Dim objOL As Outlook.Application
        Dim objMsg As Object
        Dim objAttachments As Outlook.Attachments
        Dim objSelection As Outlook.Selection
        Dim i As Long
        Dim lngCount As Long
        Dim strFile As String
        Dim strFolder As String

        On Error Resume Next

        ' Instantiate an Outlook Application object.
        Set objOL = CreateObject("Outlook.Application")
        ' Get the collection of selected objects.
        Set objSelection = objOL.ActiveExplorer.Selection

        ' Get the Temp folder.
        strFolder = "C:\MY DOCUMENTS\New Change Orders\"
           
        ' Check each selected item for attachments.
        ' If attachments exist, save them to the Temp
        ' folder and strip them from the item.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.Count
                If lngCount > 0 Then
                    ' We need to use a count down loop for
                    ' removing items from a collection. Otherwise,
                    ' the loop counter gets confused and only every
                    ' other item is removed.
                    For i = lngCount To 1 Step -1
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        strFile = objAttachments.Item(i).FileName
                        ' Combine with the path to the Temp folder.
                        strFile = strFolder & strFile
                        ' Save the attachment as a file.
                        objAttachments.Item(i).SaveAsFile strFile
                        ' Delete the attachment.
                        objAttachments.Item(i).Delete
                    Next i
                End If
                objMsg.Save
            End If
        Next

    ExitSub:
        Set objAttachments = Nothing
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
    End Sub

    Public Sub OutlookRecipsToExcel(oMail As Outlook.MailItem)
      'Excel definitions
      Dim oExcel As Excel.Application
      Dim oRange As Excel.Range
      Dim oSheet As Excel.Worksheet
      'Number of sheets in new WorkBook
      Dim lSheets As Long
     
      'Outlook definitions
      Dim oRecips As Outlook.Items
      Dim oRecip As Outlook.ContactItem
      Dim sRange As String
      Dim sCol As String
      Dim iRow As Integer
     
      'Initialize Outlook items
      Set oRecips = oMail.Recipients
     
      'Get an Excel Application object
      Set oExcel = GetObject(, "Excel.Application")
      If oExcel Is Nothing Then
        Set oExcel = CreateObject("Excel.Application")
      End If
     
      'Initialize Excel items
      'Save the previous setting for the number of Sheets
      'in a new WorkBook
      lSheets = oExcel.SheetsInNewWorkbook
      'Only 1 sheet in this WorkBook
      oExcel.SheetsInNewWorkbook = 1
      'Create a new WorkBook and make it active
      oExcel.Workbooks.Add
      'Activate Sheet 1
      Set oSheet = oExcel.ActiveWorkbook.Sheets(1)
      oSheet.Activate
      oExcel.Visible = True
     
      'Column A, Row 1 Sheet Title - Bold, 14 pt, underlined
      Set oRange = oSheet.Range("A1")
      SetSheetHeadings oRange, "Outlook Contacts", True, 14, _
        xlHairline, xlLineStyleNone, xlUnderlineStyleSingle
     
      'Start adding data at Column A, Row 3
      iRow = 2 'this number will be incremented in the For Each loop
     
      For Each oRecip In oRecips
        If oRecip.Type = olTo Then
            sCol = "A"
            sCol = Chr(Asc(sCol) - 1)
            'Start a new data Row
            iRow = iRow + 1
           
            With oRecipient
                SetRangeData oSheet, sCol, iRow, .Name
                SetRangeData oSheet, sCol, iRow, ..Address
                SetRangeData oSheet, sCol, iRow, oMail.Subject
            End With
        End If
      Next oRecip
     
      'Set a Range covering all the data in the Sheet
      sRange = "A3:" & sRange
     
      'AutoFit the Columns
      oSheet.Range(sRange).Columns.AutoFit
      'AutoFit the Rows
      oSheet.Range(sRange).Rows.AutoFit
     
      'Restore the old setting for number of Sheets
      'in a new WorkBook
      oExcel.SheetsInNewWorkbook = lSheets
     
      Set oSheet = Nothing
      Set oRange = Nothing
      Set oExcel = Nothing
      Set oContact = Nothing
      Set oItem = Nothing
      Set oItems = Nothing
      Set oFolder = Nothing
      Set oNS = Nothing
      Set oOutlook = Nothing
    End Sub
     
    Private Sub SetRangeData(oSheet As Excel.Worksheet, sCol As String, _
            iRow As Integer, sValue As String)
      Dim oRange As Excel.Range
      Dim sRange As String
     
      sCol = Chr(Asc(sCol) + 1)
      sRange = sCol & CStr(iRow)
      Set oRange = oSheet.Range(sRange)
      oRange.Value = sValue
     
      Set oRange = Nothing
    End Sub

    Thursday, March 29, 2012 2:02 PM
  • If the code is supposed to be running in the Outlook VBA project do not use CreateObject() to get a reference to the Outlook.Application object. Use the built-in trusted Application object:
     
        ' Instantiate an Outlook Application object.
        Set objOL = Application
     
    In your loop you're getting a mail item as "objMsg". It's declared as Object, but after the line "If objMsg.Class = olMail Then" the object is known to be a mail item. At some point in that loop call the procedure with objMsg. That would look like this, assuming where I put the call is where you want it to be.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
                OutlookRecipsToExcel objMsg
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                ' and so on

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:bc00c291-997b-4d27-a75a-d9883a59a063...

    This is what I have, is this how it should look?  I just added the code you provided after the code I already had.

    Public Sub StripAttachments()
        Dim objOL As Outlook.Application
        Dim objMsg As Object
        Dim objAttachments As Outlook.Attachments
        Dim objSelection As Outlook.Selection
        Dim i As Long
        Dim lngCount As Long
        Dim strFile As String
        Dim strFolder As String

        On Error Resume Next

        ' Instantiate an Outlook Application object.
        Set objOL = CreateObject("Outlook.Application")
        ' Get the collection of selected objects.
        Set objSelection = objOL.ActiveExplorer.Selection

        ' Get the Temp folder.
        strFolder = "C:\MY DOCUMENTS\New Change Orders\"
           
        ' Check each selected item for attachments.
        ' If attachments exist, save them to the Temp
        ' folder and strip them from the item.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.Count
                If lngCount > 0 Then
                    ' We need to use a count down loop for
                    ' removing items from a collection. Otherwise,
                    ' the loop counter gets confused and only every
                    ' other item is removed.
                    For i = lngCount To 1 Step -1
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        strFile = objAttachments.Item(i).FileName
                        ' Combine with the path to the Temp folder.
                        strFile = strFolder & strFile
                        ' Save the attachment as a file.
                        objAttachments.Item(i).SaveAsFile strFile
                        ' Delete the attachment.
                        objAttachments.Item(i).Delete
                    Next i
                End If
                objMsg.Save
            End If
        Next

    ExitSub:
        Set objAttachments = Nothing
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
    End Sub

    Public Sub OutlookRecipsToExcel(oMail As Outlook.MailItem)
      'Excel definitions
      Dim oExcel As Excel.Application
      Dim oRange As Excel.Range
      Dim oSheet As Excel.Worksheet
      'Number of sheets in new WorkBook
      Dim lSheets As Long
     
      'Outlook definitions
      Dim oRecips As Outlook.Items
      Dim oRecip As Outlook.ContactItem
      Dim sRange As String
      Dim sCol As String
      Dim iRow As Integer
     
      'Initialize Outlook items
      Set oRecips = oMail.Recipients
     
      'Get an Excel Application object
      Set oExcel = GetObject(, "Excel.Application")
      If oExcel Is Nothing Then
        Set oExcel = CreateObject("Excel.Application")
      End If
     
      'Initialize Excel items
      'Save the previous setting for the number of Sheets
      'in a new WorkBook
      lSheets = oExcel.SheetsInNewWorkbook
      'Only 1 sheet in this WorkBook
      oExcel.SheetsInNewWorkbook = 1
      'Create a new WorkBook and make it active
      oExcel.Workbooks.Add
      'Activate Sheet 1
      Set oSheet = oExcel.ActiveWorkbook.Sheets(1)
      oSheet.Activate
      oExcel.Visible = True
     
      'Column A, Row 1 Sheet Title - Bold, 14 pt, underlined
      Set oRange = oSheet.Range("A1")
      SetSheetHeadings oRange, "Outlook Contacts", True, 14, _
        xlHairline, xlLineStyleNone, xlUnderlineStyleSingle
     
      'Start adding data at Column A, Row 3
      iRow = 2 'this number will be incremented in the For Each loop
     
      For Each oRecip In oRecips
        If oRecip.Type = olTo Then
            sCol = "A"
            sCol = Chr(Asc(sCol) - 1)
            'Start a new data Row
            iRow = iRow + 1
           
            With oRecipient
                SetRangeData oSheet, sCol, iRow, ..Name
                SetRangeData oSheet, sCol, iRow, ...Address
                SetRangeData oSheet, sCol, iRow, oMail.Subject
            End With
        End If
      Next oRecip
     
      'Set a Range covering all the data in the Sheet
      sRange = "A3:" & sRange
     
      'AutoFit the Columns
      oSheet.Range(sRange).Columns.AutoFit
      'AutoFit the Rows
      oSheet.Range(sRange).Rows.AutoFit
     
      'Restore the old setting for number of Sheets
      'in a new WorkBook
      oExcel.SheetsInNewWorkbook = lSheets
     
      Set oSheet = Nothing
      Set oRange = Nothing
      Set oExcel = Nothing
      Set oContact = Nothing
      Set oItem = Nothing
      Set oItems = Nothing
      Set oFolder = Nothing
      Set oNS = Nothing
      Set oOutlook = Nothing
    End Sub
     
    Private Sub SetRangeData(oSheet As Excel.Worksheet, sCol As String, _
            iRow As Integer, sValue As String)
      Dim oRange As Excel.Range
      Dim sRange As String
     
      sCol = Chr(Asc(sCol) + 1)
      sRange = sCol & CStr(iRow)
      Set oRange = oSheet.Range(sRange)
      oRange.Value = sValue
     
      Set oRange = Nothing
    End Sub


    Ken Slovak MVP - Outlook
    Thursday, March 29, 2012 2:55 PM
    Moderator
  • I made the changes you suggested.  When I run the debugger, however, it highlights the line that reads "SetSheetHeadings" and gives me an error message that reads "Compile error:  Sub or Function not defined".  Now what do I need to do?
    Thursday, March 29, 2012 7:51 PM
  • Delete this, I left it in by mistake.
     
      SetSheetHeadings oRange, "Outlook Contacts", True, 14, _
        xlHairline, xlLineStyleNone, xlUnderlineStyleSingle
    That code was taken from something I use to produce formatted worksheets for an addin, I missed removing that header line.

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:8c136c3d-c746-4ee2-87a0-bf26dc251fba...
    I made the changes you suggested.  When I run the debugger, however, it highlights the line that reads "SetSheetHeadings" and gives me an error message that reads "Compile error:  Sub or Function not defined".  Now what do I need to do?

    Ken Slovak MVP - Outlook
    Thursday, March 29, 2012 7:57 PM
    Moderator
  • Okay, I took those lines out and ran the code.  I did not get any error messages, however, I also did not get any results with the recipient name.

    I just had a thought, would it be easier to pull the recipient name and just tack it on to the name of the attachment (i.e. attachment name - "ChangeOrder for Drucker's Store.pdf" - could it change to "Joe Smith ChangeOrder for Drucker's Store.pdf"or even "Joe.Smith@mail.com ChangeOrder for Drucker's Store.pdf")?  If it could be done that way, I wouldn't need the subject line.  What do you think?  Would that be easier?

    Thursday, March 29, 2012 8:42 PM
  • I botched the editing of that code, let's try this again. Just bear in mind that the address that will be put into Excel is an Exchange address if the sender is someone from your own Exchange GAL (if you're using Exchange).
     
    Public Sub StripAttachments()
        Dim objOL As Outlook.Application
        Dim objMsg As Object
        Dim objAttachments As Outlook.Attachments
        Dim objSelection As Outlook.Selection
        Dim i As Long
        Dim lngCount As Long
        Dim strFile As String
        Dim strFolder As String
     
        On Error Resume Next
     
        ' Instantiate an Outlook Application object.
        Set objOL = Application
        ' Get the collection of selected objects.
        Set objSelection = objOL.ActiveExplorer.Selection
     
        ' Get the Temp folder.
        strFolder = "C:\MY DOCUMENTS\New Change Orders\"
           
        ' Check each selected item for attachments.
        ' If attachments exist, save them to the Temp
        ' folder and strip them from the item.
        For Each objMsg In objSelection
            ' This code only strips attachments from mail items.
            If objMsg.Class = olMail Then
                OutlookRecipsToExcel objMsg
     
                ' Get the Attachments collection of the item.
                Set objAttachments = objMsg.Attachments
                lngCount = objAttachments.count
                If lngCount > 0 Then
                    ' We need to use a count down loop for
                    ' removing items from a collection. Otherwise,
                    ' the loop counter gets confused and only every
                    ' other item is removed.
                    For i = lngCount To 1 Step -1
                        ' Save attachment before deleting from item.
                        ' Get the file name.
                        strFile = objAttachments.Item(i).FileName
                        ' Combine with the path to the Temp folder.
                        strFile = strFolder & strFile
                        ' Save the attachment as a file.
                        objAttachments.Item(i).SaveAsFile strFile
                        ' Delete the attachment.
                        objAttachments.Item(i).Delete
                    Next i
                End If
                objMsg.Save
            End If
        Next
     
    ExitSub:
        Set objAttachments = Nothing
        Set objMsg = Nothing
        Set objSelection = Nothing
        Set objOL = Nothing
    End Sub
     

    Public Sub OutlookRecipsToExcel(oMail As Outlook.MailItem)
      'Excel definitions
      Dim oExcel As Excel.Application
      Dim oRange As Excel.Range
      Dim oSheet As Excel.Worksheet
      'Number of sheets in new WorkBook
      Dim lSheets As Long
     
      'Outlook definitions
      Dim oRecips As Outlook.Recipients
      Dim oRecip As Outlook.Recipient
     
      Dim sRange As String
      Dim sCol As String
      Dim iRow As Integer
     
      'Initialize Outlook items
      Set oRecips = oMail.Recipients
     
      'Get an Excel Application object
      'Set oExcel = GetObject(, "Excel.Application")
      'If oExcel Is Nothing Then
        Set oExcel = CreateObject("Excel.Application")
      'End If
     
      'Initialize Excel items
      'Save the previous setting for the number of Sheets
      'in a new WorkBook
      lSheets = oExcel.SheetsInNewWorkbook
      'Only 1 sheet in this WorkBook
      oExcel.SheetsInNewWorkbook = 1
      'Create a new WorkBook and make it active
      oExcel.Workbooks.Add
      'Activate Sheet 1
      Set oSheet = oExcel.ActiveWorkbook.Sheets(1)
      oSheet.Activate
      oExcel.Visible = True
     
      'Column A, Row 1 Sheet Title - Bold, 14 pt, underlined
      Set oRange = oSheet.Range("A1")
     
      'Start adding data at Column A, Row 3
      iRow = 2 'this number will be incremented in the For Each loop
     
      For Each oRecip In oRecips
        If oRecip.Type = olTo Then
            sCol = "A"
            sCol = Chr(Asc(sCol) - 1)
            'Start a new data Row
            iRow = iRow + 1
           
            With oRecip
                SetRangeData oSheet, sCol, iRow, ..name
                SetRangeData oSheet, sCol, iRow, ..Address
                SetRangeData oSheet, sCol, iRow, oMail.Subject
            End With
        End If
      Next oRecip
     
      'Set a Range covering all the data in the Sheet
      sRange = "A3:" & sRange
     
      'AutoFit the Columns
      oSheet.Range(sRange).Columns.AutoFit
      'AutoFit the Rows
      oSheet.Range(sRange).rows.AutoFit
     
      'Restore the old setting for number of Sheets
      'in a new WorkBook
      oExcel.SheetsInNewWorkbook = lSheets
     
      Set oSheet = Nothing
      Set oRange = Nothing
      Set oExcel = Nothing
      Set oRecip = Nothing
      Set oRecips = Nothing
    End Sub
     
    Private Sub SetRangeData(oSheet As Excel.Worksheet, sCol As String, _
            iRow As Integer, sValue As String)
      Dim oRange As Excel.Range
      Dim sRange As String
     
      sCol = Chr(Asc(sCol) + 1)
      sRange = sCol & CStr(iRow)
      Set oRange = oSheet.Range(sRange)
      oRange.Value = sValue
     
      Set oRange = Nothing
    End Sub

    --
    Ken Slovak
    MVP - Outlook
    http://www.slovaktech.com
    Author: Professional Programming Outlook 2007
     
     
    "AuntDi" <=?utf-8?B?QXVudERp?=> wrote in message news:1ea4fee0-54b6-4a70-8378-6e802fd7b2c1...

    Okay, I took those lines out and ran the code.  I did not get any error messages, however, I also did not get any results with the recipient name.

    I just had a thought, would it be easier to pull the recipient name and just tack it on to the name of the attachment (i.e. attachment name - "ChangeOrder for Drucker's Store.pdf" - could it change to "Joe Smith ChangeOrder for Drucker's Store.pdf"or even "Joe.Smith@mail.com ChangeOrder for Drucker's Store.pdf")?  If it could be done that way, I wouldn't need the subject line.  What do you think?  Would that be easier?


    Ken Slovak MVP - Outlook
    Thursday, March 29, 2012 9:25 PM
    Moderator