Consulting

Results 1 to 4 of 4

Thread: Extract subject with specific keyword, sender, date/time, export to Excel

  1. #1
    VBAX Newbie
    Joined
    May 2020
    Posts
    5
    Location

    Extract subject with specific keyword, sender, date/time, export to Excel

    I've never asked a question like this before so I apologize in advance. Long story short, I haven't worked w. VBA for 2 years now. I lost all of my notes and data due to what can only be called a personal tragedy. I've spent 2 days attempting to figure this out on my own using this great site and a couple others but after trying to tweak several different modules from the 3 sites and having no success, I'm basically just spinning my wheels and not making any progress. I tried calling one ex-coworker but he's OCONUS right now.
    Description:
    I need to process incoming emails with a keyword in the subject, (i.e. Logging), export the sender, subject, date&time the email was received to
    an excel spreadsheet (C:\data\Logging\logging.xlsc), then move the email to a subfolder (Logging) in the current mailbox. This processing should be done automatically. Normally I would insert the code I've tried, but I basically have nothing but overcooked spaghetti code that doesn't do anything. I apologize for this question but I'm in a bind and I need to get this working. I do plan on taking some online training this week and next week to get the basics back, but I need a solution tomorrow if possible, Tuesday at the latest.

  2. #2
    This is very similar to code I have posted previously. Use a rule to identify the messages as they arrive, run the script 'ExtractLoggingData', and move the message to your folder of choice. The macro will create the path and workbook if not present. I have included a test macro so that you can test the code with a selected message.

    Option Explicit
    
    Private strDate As String
    Private strTime As String
    Private strEmail As String
    Private strSubject As String
    Private strValues As String
    Private vValues As Variant
    Private ConnectionString As String
    Private strSQL As String
    Private CN As Object
    Private xlApp As Object
    Private xlWB As Object
    Private bxlStarted As Boolean
    Private i As Long
    Private Const strTitles As String = "Date|Time|E-Mail|Subject"
    Private Const strWorkbook As String = "Logging.xlsx"
    Private Const strPath As String = "C:\Data\Logging\"
    
    Sub Test()
    Dim olMsg As MailItem
        On Error Resume Next
        Select Case Outlook.Application.ActiveWindow.Class
            Case olInspector
                Set olMsg = ActiveInspector.currentItem
            Case olExplorer
                Set olMsg = Application.ActiveExplorer.Selection.Item(1)
        End Select
        ExtractLoggingData olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    Sub ExtractLoggingData(Item As MailItem)
    'Graham Mayor - https://www.gmayor.com - Last updated - 11 May 2020
        If TypeName(Item) = "MailItem" Then
            strEmail = Item.SenderEmailAddress
            strDate = Format(Item.ReceivedTime, "dd/MM/yyyy")
            strTime = Format(Item.ReceivedTime, "h:mm am/pm")
            strSubject = Item.Subject
            strValues = strDate & "', '" & _
                        strTime & "', '" & _
                        strEmail & "', '" & _
                        strSubject
            If Not FileExists(strPath & strWorkbook) = True Then xlCreateBook strWorkbook:=strPath & strWorkbook, strTitles:=strTitles
            WriteToWorksheet strWorkbook:=strPath & strWorkbook, strRange:="Sheet1", strValues:=strValues
        End If
    lbl_Exit:
        Exit Sub
    End Sub
    
    Private Function WriteToWorksheet(strWorkbook As String, _
                                      strRange As String, _
                                      strValues As String)
        ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                           "Data Source=" & strWorkbook & ";" & _
                           "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
        strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
        Set CN = CreateObject("ADODB.Connection")
        Call CN.Open(ConnectionString)
        Call CN.Execute(strSQL, , 1 Or 128)
        CN.Close
        Set CN = Nothing
    lbl_Exit:
        Exit Function
    End Function
    
    Private Sub xlCreateBook(strWorkbook As String, strTitles As String)
        CreateFolders strPath
        vValues = Split(strTitles, "|")
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err <> 0 Then
            Set xlApp = CreateObject("Excel.Application")
            bxlStarted = True
        End If
        On Error GoTo 0
        Set xlWB = xlApp.Workbooks.Add
        With xlWB.Sheets(1)
            For i = 0 To UBound(vValues)
                .cells(1, i + 1) = vValues(i)
            Next i
        End With
        xlWB.SaveAs strWorkbook
        xlWB.Close 1
        If bxlStarted Then
            xlApp.Quit
            Set xlApp = Nothing
            Set xlWB = Nothing
        End If
    lbl_Exit:
        Exit Sub
    End Sub
    
    Private Function CreateFolders(strPath As String)
    'An Outlook macro by Graham Mayor
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function FolderExists(fldr) As Boolean
    'An Outlook macro by Graham Mayor
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If (FSO.FolderExists(fldr)) Then
            FolderExists = True
        Else
            FolderExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    
    Private Function FileExists(filespec) As Boolean
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(filespec) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    May 2020
    Posts
    5
    Location
    Awesome! TYVM! I’ll test it first thing in the morning. YOU ROCK!

  4. #4
    VBAX Newbie
    Joined
    May 2020
    Posts
    5
    Location
    WELP! I just found out that I no longer need this because a different route is going to be used, which means I wasted my weekend and some of your time too (sort of). What I AM going to do is save this, use it as an example of how to write good code, and break it down, see if I can get the basics back, and understand everything in all of the functions. So at this point, your code is still going to be very helpful, since as I said I'll be using it as a 'how to'. Also I haven't gone to your site yet but based on what I've seen you may want to put together a QND pdf and advertise/sell it for people who are either just starting or are getting back into VBA after a long time away. Put some of your code examples/functions, comments explaining why/how/what, etc.. I'm serious, I think people, EVEN ME, would buy it! I usually prefer to learn on my own and I've been geeking out for longer than I like to remember, but again, with something as awesome, flexible, and powerful as VBA, while there are many resources out there, it seems to me as if you could provide something and actually get some profit from it, assuming you're interested. Thanks again for your help. UPDATE: Came back to edit this after visiting your site. Sent you a little thank you via PP.
    Last edited by Lemmein; 05-11-2020 at 11:12 AM.

Tags for this Thread

Posting Permissions

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