20$ Export from outlook to Excel

[Excel Fox]

I'll try to get something in over the weekend.

[jamilm]

i am sorry to be nagging you on this, but i was wondering to know if there is any progress made on my code?

thanks.

I'll try to get something in over the weekend.

[snb]

Here you are:

Sub M_snb()
  With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6)
    redim sn(.items.count,2)

    j=0
    for each it in .Items
      sn(j,0)=it.To 
      sn(j,1)=it.subject
      sn(j,2)=it.body
      j=j+1
    next
  End With

  thisworkbook.sheets(1).cells(1).resize(ubound(sn)+1,ubound(sn,2)+1)=sn
End Sub

[jamilm]

Dear Snb,

your code does not do nothing. i believe that you did not understand what the requirement of my project was. currently the Administrator is working on it. so, please do not bother.

regards,

[jamilm]

Administrator.

any luck with my outlook code?

[Excel Fox]

Some luck, but not all that's needed. Will post something later tonight.

[Excel Fox]

Option Explicit

Sub ExportToExcelV2()


    Dim appExcel As Excel.Application
    Dim appOutlook As Outlook.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
    Dim lngColIndex As Long
    
    On Error GoTo ErrHandler
    Set appExcel = Application 'CreateObject("Excel.Application")
    Set appOutlook = GetObject(, "Outlook.Application")
    appExcel.Application.Visible = True
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets("exported data")
    appExcel.GoTo wks.Cells(1)
    Set nms = appOutlook.GetNamespace("MAPI")
    Do
        Stop
        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"
            GoTo JumpExit
        ElseIf FolderSelected.DefaultItemType <> olMailItem Then
            MsgBox "These are not Mail Items", vbOKOnly, "Error"
            GoTo JumpExit
        ElseIf FolderSelected.Items.Count = 0 Then
            MsgBox "There are no mail messages to export", vbOKOnly, "Error"
            GoTo JumpExit
        End If
         'Copy field items in mail folder.
        intRowCounter = 1
        lngColIndex = 1
        wks.Cells(intRowCounter, lngColIndex).Resize(, 9).Value = Array("To", "From", "Subject", "Body", "Received", "Folder", "Category", "Flag Status", "Client")
        intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
        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 = ResolveDisplayNameToSMTP(msg.SenderEmailAddress, appOutlook)
                If varSender = vbNullString Then varSender = msg.SenderEmailAddress
                 '============================================================
                 wks.Cells(intRowCounter, 2).Resize(, 8).Value = Array(varSender, RemoveREFW(msg.Subject), Left(msg.Body, 50), msg.ReceivedTime, FolderSelected.Name, msg.Categories, msg.FlagStatus, "=ISNA(MATCH(RC[-7],NonClient,0))")
                 varSender = vbNullString
            End If 'TypeOf
        Next itm
    Loop
JumpExit:
    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
    Err.Clear: On Error GoTo 0: On Error GoTo -1
    GoTo JumpExit
    
End Sub


Function ResolveDisplayNameToSMTP(sFromName, objApp As Object)
     
    Dim oRecip As Recipient
    Dim oEU As ExchangeUser
    Dim oEDL As ExchangeDistributionList
     
    Set oRecip = objApp.Session.CreateRecipient(sFromName)
    oRecip.Resolve
    If oRecip.Resolved Then
        Select Case oRecip.AddressEntry.AddressEntryUserType
        Case OlAddressEntryUserType.olExchangeUserAddressEntry, OlAddressEntryUserType.olOutlookContactAddressEntry
            Set oEU = oRecip.AddressEntry.GetExchangeUser
            If Not (oEU Is Nothing) Then
                ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
            End If
        Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
            Set oEDL = oRecip.AddressEntry.GetExchangeDistributionList
            If Not (oEDL Is Nothing) Then
                ResolveDisplayNameToSMTP = oEDL.PrimarySmtpAddress
            End If
        End Select
    End If
     
End Function


Private Function RemoveREFW(str As String) As String


    If Left$(UCase(str), 3) = "RE:" Or Left$(UCase(str), 3) = "FW:" Then
        str = Trim$(Mid$(str, 4))
    ElseIf Left(UCase(str), 4) = "FWD:" Then
        str = Trim$(Mid$(str, 5))
    End If
    RemoveREFW = Trim$(Replace$(Replace$(Replace$(str, "RE:", "", , , vbTextCompare), "FW:", "", , , vbTextCompare), "FWD:", "", , , vbTextCompare))
    
End Function


Sub CreatePiv()
    
    Dim pvc As PivotCache
    Dim pvt As PivotTable
    
    With ThisWorkbook
        Application.DisplayAlerts = 0
        On Error Resume Next
        .Worksheets("Output").Delete
        Err.Clear: On Error GoTo 0: On Error GoTo -1
        Application.DisplayAlerts = 1
        .Worksheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Output"
        Set pvc = .PivotCaches.Create(SourceType:=xlDatabase, SourceData:=.Worksheets("Exported Data").Cells(1).CurrentRegion.Address(, , xlR1C1, True), Version:=xlPivotTableVersion12)
        Set pvt = pvc.CreatePivotTable(TableDestination:="Output!R3C1", TableName:="PvtCustom", DefaultVersion:=xlPivotTableVersion12)
    End With
    With pvt.PivotFields("Subject")
        .Orientation = xlRowField
        .Position = 1
        .Subtotals(1) = False
    End With
    With pvt.PivotFields("Received")
        .Orientation = xlRowField
        .Position = 2
        .Subtotals(1) = False
    End With
    With pvt.PivotFields("From")
        .Orientation = xlRowField
        .Position = 3
        .Subtotals(1) = False
    End With
    With pvt.PivotFields("Client")
        .Orientation = xlRowField
        .Position = 4
        .Subtotals(1) = False
    End With
    With pvt.PivotFields("Flag Status")
        .Orientation = xlRowField
        .Position = 5
        .Subtotals(1) = False
    End With
    With pvt
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
        .ColumnGrand = False
        .RowGrand = False
    End With
    
End Sub

The task completed date is always showing 1/1/4501

When does this show something else?

[jamilm]

The task completed date is always showing 1/1/4501

When does this show something else?

Dear Administrator.

do not worry about the task completed date. you can remove that part entirely. all what matters is the received date .

you shall remove the code intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.TaskCompletedDate

[ashu1990]

hi would like to give a try what exactly do you need?

[Excel Fox]

hi ashu1990, Jamil is already in interaction with me over email, and we are working it out. Anyway, if you want to try out out of interest, please go ahead. Everything is explained in the posts above.