Results 1 to 3 of 3

Thread: Export outlook emails to Excel code Error

  1. #1
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0

    Export outlook emails to Excel code Error

    Dear Gurus,

    i have the following code which was working before and don't know what happen now my debugger stops at Set rep = itm

    any help will be appreciated. thanks.

    Code:
    Sub ExportfromoutlooktoExcel()
    
      
    
    'On Error GoTo ErrorHandler
    
      
    
    Dim appExcel As Excel.Application
    
    Dim wkb As Excel.Workbook
    
    Dim wks As Excel.Worksheet
    
    Dim rng As Excel.Range
    
    Dim strSheet As String
    
    Dim strPath As String
    
    Dim i As Integer
    
    Dim j As Integer
    
    Dim lngCount As Long
    
    Dim msg As Outlook.MailItem
    
    Dim rep As Outlook.ReportItem
    
    Dim nms As Outlook.NameSpace
    
    Dim fld As Outlook.MAPIFolder
    
    'Must declare as Object because folders may contain different
    
    'types of items
    
    Dim itm As Object
    
    Dim strTitle As String
    
    Dim strPrompt As String
    
    Dim Proceed
    
      
    
    Dim fYear, rYear, iMonth As Integer
    
    Dim rMonth As String
    
      
    
      
    
    Set appExcel = CreateObject("Excel.Application")
    
    Workbooks.Add
    
    Set wkb = appExcel.ActiveWorkbook
    
    Set wks = wkb.Sheets(1)
    
    wks.Activate
    
    appExcel.Application.Visible = True
    
        Sheets("Sheet1").Select
    
        Sheets("Sheet1").Name = "Email"
    
       
    
     
    
    'Adjust i (row number) to be 1 less than the number of the first body row
    
    i = 1
    
    j = 1
    
      
    
    'Create Header Row
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "Subject"
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "Body"
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "FromName"
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "ToName"
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "Importance"
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "Sensitivity"
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = "Action Date"
    
      
    
    Proceed = MsgBox("Export for Misc Test?", vbYesNo, "Misc Test?")
    
      
    
    If Proceed = 7 Then
    
      
    
    ''Calculate the fiscal year
    
    If Month(Date) = 12 Then
    
        fYear = Year(Date) + 1
    
    Else
    
        fYear = Year(Date)
    
    End If
    
      
    
    'Calculate the report calendar year and report month
    
    If Month(Date) = 1 Then
    
        rYear = Year(Date) - 1
    
        iMonth = 12
    
    Else
    
        rYear = Year(Date)
    
        iMonth = Month(Date) - 1
    
    End If
    
      
    
    If iMonth < 10 Then
    
        rMonth = "0" & iMonth
    
    Else
    
        rMonth = iMonth
    
    End If
    
      
    
    ActiveWorkbook.SaveAs "C:\Users\jamilm\Downloads\FY" & fYear & "\" & rMonth & "." & rYear, 51
    
    
    Else
    
      
    
    appExcel.DisplayAlerts = False
    
    ActiveWorkbook.SaveAs "C:\Users\jamilm\Downloads\misc.xlsx"
    
    appExcel.DisplayAlerts = True
    
      
    
    End If
    
      
    
      
    
    'Let user select a folder to export
    
    Set nms = Application.GetNamespace("MAPI")
    
    Set fld = nms.PickFolder
    
    If fld Is Nothing Then
    
    GoTo ErrorHandlerExit
    
    End If
    
      
    
    'Test whether selected folder contains mail messages
    
    If fld.DefaultItemType <> olMailItem Then
    
    MsgBox "Folder does not contain mail messages"
    
    GoTo ErrorHandlerExit
    
    End If
    
      
    
    lngCount = fld.Items.Count
    
      
    
    If lngCount = 0 Then
    
    MsgBox "No messages to export"
    
    GoTo ErrorHandlerExit
    
    End If
    
      
    
     
    
     
    
    'Iterate through items in the folder, and export a few fields
    
    'from each item to a row in the worksheet
    
    For Each itm In fld.Items
    
    If itm.Class = olMail Then
    
      
    
    Set msg = itm
    
    'i is the row number
    
    i = i + 1
    
    'j is the column number
    
    j = 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    If msg.Subject <> "" Then rng.Value = msg.Subject
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    If msg.Body <> "" Then rng.Value = msg.Body
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    If msg.SenderName <> "" Then rng.Value = msg.SenderName
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    If msg.To <> "" Then rng.Value = msg.To
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = msg.Importance
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = msg.Sensitivity
    
      
    
    Set rng = wks.Cells(i, j)
    
    If msg.To <> "" Then rng.Value = msg.ReceivedTime
    
    j = j + 1
    
      
    
    Else
    
      
    
    Set rep = itm
    
    'i is the row number
    
    i = i + 1
    
    'j is the column number
    
    j = 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    If rep.Subject <> "" Then rng.Value = rep.Subject
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    If rep.Body <> "" Then rng.Value = rep.Body
    
    j = j + 3
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = msg.Importance
    
    j = j + 1
    
      
    
    Set rng = wks.Cells(i, j)
    
    rng.Value = msg.Sensitivity
    
      
    
    End If
    
    Next itm
    
      
    
      
    
    Range("B:B").Select
    
    Selection.WrapText = False
    
      
    
    ActiveWorkbook.Save
    
    ActiveWorkbook.Close
    
    appExcel.Quit
    
      
    
    Set appExcel = Nothing
    
    Set wkb = Nothing
    
    Set wks = Nothing
    
    Set rng = Nothing
    
    Set msg = Nothing
    
    Set rep = Nothing
    
    Set nms = Nothing
    
    Set fld = Nothing
    
    Set itm = Nothing
    
      
    
    ErrorHandlerExit:
    
    Exit Sub
    
      
    
    ErrorHandler:
    
    If Err.Number = 429 Then
    
    'Application object is not set by GetObject; use CreateObject instead
    
        If appExcel Is Nothing Then
    
            Set appExcel = CreateObject("Excel.Application")
    
            Resume Next
    
        End If
    
    Else
    
    MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
    
      
    
    Resume ErrorHandlerExit
    
    End If
    
      
    
    End Sub

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    One issue may be that your inbox may contain other items apart from MailItem and ReportItem (and that may be why you started to get error recently in a code that was working fine before). Run the code, and find out on which item the error occurs. That may give you a clue as to what other item it is.

    You may also want to check the class property of the item to ensure it is one of MailItem or ReportItem
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Member
    Join Date
    Dec 2012
    Posts
    43
    Rep Power
    0
    Quote Originally Posted by Excel Fox View Post
    One issue may be that your inbox may contain other items apart from MailItem and ReportItem (and that may be why you started to get error recently in a code that was working fine before). Run the code, and find out on which item the error occurs. That may give you a clue as to what other item it is.

    You may also want to check the class property of the item to ensure it is one of MailItem or ReportItem

    i could not figure out the problem, i tried all methods. but finally i found another code from a thread of excel community which works, except for the part that
    Code:
    intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.Body
    this extracts long message, i just want the first 30 char of the body message to be excerpted not all. besides, if i could also excerpt the other information such flag status and category. i do not know how to put addtional code into the code below, to get the flag status and category also.

    any help will be appreciated.



    Code:
    Sub ExportToExcelV2()
    On Error GoTo ErrHandler
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim FolderSelected As Outlook.MAPIFolder
    Dim varSender As String
    Dim itm As Object
    '    strSheet = "OutlookItems.xlsx"
    '    strPath = "C:\Users\jamilm\Downloads"
    'strSheet = strPath & strSheet
    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Application.Visible = True
    strSheet = appExcel.GetOpenFilename("Excel Files(*.xl*),*.xl*", 1, "Select Excel File", "Select", False)
    appExcel.Workbooks.Open strSheet
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    wks.Activate
      'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Do
    Set FolderSelected = nms.PickFolder
      'Handle potential errors with Select Folder dialog box.
    If FolderSelected Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf FolderSelected.DefaultItemType <> olMailItem Then
        MsgBox "These are not Mail Items", vbOKOnly, "Error"
        Exit Sub
    ElseIf FolderSelected.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    End If
      'Copy field items in mail folder.
     
    intRowCounter = 1
    colidx = 1
    wks.Cells(intRowCounter, colidx) = "To": colidx = colidx + 1
    wks.Cells(intRowCounter, colidx) = "From": colidx = colidx + 1
    wks.Cells(intRowCounter, colidx) = "Subject": colidx = colidx + 1
    wks.Cells(intRowCounter, colidx) = "Body": colidx = colidx + 1
    wks.Cells(intRowCounter, colidx) = "Received": colidx = colidx + 1
    wks.Cells(intRowCounter, colidx) = "Folder": colidx = colidx + 1
    intRowCounter = wks.UsedRange.Rows.Count
    For Each itm In FolderSelected.Items
    intColumnCounter = 1
    If TypeOf itm Is MailItem Then
    Set msg = itm
    intRowCounter = intRowCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.To
    varSender = msg.SenderEmailAddress
    '============================================================
    If InStr(1, msg.SenderEmailAddress, "501288010", vbTextCompare) > 0 Then
        varSender = "Todd Curphey"
    Else
        varSender = msg.SenderEmailAddress
    End If
    If InStr(1, msg.SenderEmailAddress, "CN=RECIPIENTS/CN=", vbTextCompare) > 0 Then
        varSender = "SSO: " & Right(msg.SenderEmailAddress, 9)
    Else
        varSender = msg.SenderEmailAddress
        varSender = msg.SenderName
    End If
    '============================================================
    intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = varSender
    intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.Subject
    intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.Body
    intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.ReceivedTime
    intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = FolderSelected.Name
    End If 'TypeOf
    Next itm
    DoEvents
    Loop
      Set appExcel = Nothing
      Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set FolderSelected = Nothing
    Set itm = Nothing
      Exit Sub
    
    ErrHandler:  If Err.Number = 1004 Then
    MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
    Else
    MsgBox Err.Number & "; Description: " & Err.Description & vbCrLf & msg.ReceivedTime & vbCrLf & msg.Subject, vbOKOnly, "Error"
    End If
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set FolderSelected = Nothing
    Set itm = Nothing
    End Sub

Similar Threads

  1. Export data from Excel to Access Table (ADO) using VBA
    By Admin in forum Excel and VBA Tips and Tricks
    Replies: 4
    Last Post: 02-24-2015, 07:53 PM
  2. 20$ Export from outlook to Excel
    By jamilm in forum Hire A Developer
    Replies: 22
    Last Post: 07-16-2013, 11:27 PM
  3. Replies: 6
    Last Post: 06-05-2013, 11:33 PM
  4. Replies: 2
    Last Post: 05-23-2013, 08:08 AM
  5. Excel Error
    By aarbuckle in forum Excel Help
    Replies: 5
    Last Post: 03-13-2012, 03:12 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •