Outlook body to Excel

[jensen306]

Hi, there's someone here who can help me
I want to be able to get parts of my text from my Outlook body automatically into Excel.

In the summer, my email body looks like this.

That's all I need in red.

CURRENT WEATHER REPORT FROM: Vejr rapport Holstebro ny
Conditions: Dry
Temperature: 20.2 °C
Trend: +0.8 °C /hr
Average windspeed: 0.0 m/s
Current speed: 0.0 m/s
Direction: SW 225 °
Barometer: 950.1 hPa
Pressure trend -0.8hPa/hr
Humidity: 40 %
Dew point: 6.2 °C
Todays rain: 0.0 mm
Monthly rain: 35.7 mm
Yearly rain: 447.3 mm
Maximum temperature: 20.2 °C at time: 2:25 PM
Maximum heat index temperature: 20.2 °C at time: 2:25 PM
Minimum temperature: 9.2 °C at time: 7:21 AM
Maximum gust today: 0.0 m/s SW at time: 12:18 AM
Max gust last 10 mins:: 0.0kmh
Current Windchill: 20.2 °C
Indendørs temp.: 27.2 °C
Indendørs luft.: 50 %
Created by "Weather Display" version 10.37S Build 111 18:03:19 15-09-2021
Time of Weather report: 14:30:07 Date of report: 26-09-2021


In the winter, my email body looks like this.

CURRENT WEATHER REPORT FROM: Vejr rapport Holstebro ny
Conditions: Dry
Temperature: 2.7 0C
Trend: +0.1 0C /hr
Average windspeed: 0.0 m/s
Current speed: 0.0 m/s
Direction: SW 225 0
Barometer: 938.5 hPa
Pressure trend +0.1hPa/hr
Humidity: 61 %
Dew point: -4.1 0C
Todays rain: 0.0 mm
Monthly rain: 4.5 mm
Yearly rain: 120.6 mm
Maximum temperature: 2.7 0C at time: 12:00 AM
Minimum temperature: 2.6 0C at time: 12:07 AM
Maximum gust today: 0.0 m/s SW at time: 4:23 PM
Max gust last 10 mins:: 0.0kmh
Current Windchill: 2.7 0C
Indendxrs temp.: 26.1 0C
Indendxrs luft.: 35 %
Created by "Weather Display" version 10.37S Build 111 23:52:42 09-03-2021
Time of Weather report: 00:10:06 Date of report: 07-04-2021


I got one to make a vba code for it but I can not make it work. I get an error code run-time error-'91 ': is there anyone who can help me.

Option Explicit

Public WithEvents PersonalInboxItems As Outlook.Items
Public WithEvents PublicInboxItems As Outlook.Items
Public WithEvents PublicSubfolderItems As Outlook.Items

Private Sub Application_Startup()

   StartListeners

End Sub

Private Sub StartListeners()
   
   ' Set up listener for new items to inbox
   Set PersonalInboxItems = Application.GetNamespace("MAPI").Folders("jensen30@gmail.com").Folders("Indbakke").Items
   
End Sub

Private Sub PersonalInboxItems_ItemAdd(ByVal Item As Object)

   ' Subject to scan starts with this
   Const SubToCheck = "WEATHER REPORT FROM: Vejr rapport Holstebro ny"
   
   If Left(Item.Subject, Len(SubToCheck)) = SubToCheck Then
      Me.CaptureWeatherInfo (Item.Body)
      MsgBox "Weather update complete for " & Item.Subject
   End If

End Sub


Public Sub CaptureWeatherInfo(WeatherBody As String)

   Dim WeatherInfo As Variant ' (1 To 1, 1 To 11) As Variant
   Dim MSXL As Object ' Excel.Application
   Dim ExcelWasNotRunning As Boolean
   Dim WeatherWB As Object ' Workbook
   Const WBPath = "C:\Users\bruger\OneDrive\Dokumenter\WEATHER REPORT\WEATHER REPORT FROM Vejr.xlsm"
   Dim WeatherSheet As Object
   
   On Error Resume Next
   Set MSXL = GetObject(, "Excel.Application")
   On Error GoTo 0
   
   If Err Then
      ExcelWasNotRunning = True
      Set MSXL = CreateObject("Excel.Application")  ' New Excel.Application
   End If
   
   
   Set WeatherWB = MSXL.workbooks.Open(WBPath)
   Set WeatherSheet = WeatherWB.sheets(2)
   GetWeatherInfo WeatherBody, WeatherWB.sheets(2)
   
   WeatherWB.Save
   'WeatherWB.Close
   
   Set MSXL = Nothing
   


End Sub


Public Sub GetWeatherInfo(WeatherBody As String, WeatherSheet As Object)

Const xlUp = -4162

   Const Filename = ""
   Dim LastRow As Long
   Dim Col As Long
   Dim RE As Object

   LastRow = WeatherSheet.Cells(WeatherSheet.Rows.Count, "A").End(xlUp).Row

   Set RE = CreateObject("vbscript.regexp")
   
   WeatherBody = Replace(WeatherBody, Chr(10), "")
     
   Col = 1
   
   RE.Pattern = "^.*Temperature:.([\d\.]*).*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Humidity: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Todays rain: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Monthly rain: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Yearly rain: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Maximum temperature: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Minimum temperature: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*temp\.: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*luft\.: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Time of Weather report: ([^ ]*) .*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   Col = Col + 1
   
   RE.Pattern = "^.*Date of report: ([\d-]*).*$"
   WeatherSheet.Cells(LastRow + 1, Col) = RE.Replace(WeatherBody, "$1")
   
End Sub

 

[GWteB]

Hi & Welcome to MrExcel!

Not sure about it but perhaps changing this event procedure ...

Private Sub PersonalInboxItems_ItemAdd(ByVal Item As Object)

   ' Subject to scan starts with this
   Const SubToCheck = "WEATHER REPORT FROM: Vejr rapport Holstebro ny"
   
   If Left(Item.Subject, Len(SubToCheck)) = SubToCheck Then
      Me.CaptureWeatherInfo (Item.Body)
      MsgBox "Weather update complete for " & Item.Subject
   End If

End Sub

into this might help.

Private Sub PersonalInboxItems_ItemAdd(ByVal Item As Object)

    ' Subject to scan starts with this
    Const SubToCheck = "WEATHER REPORT FROM: Vejr rapport Holstebro ny"

    If TypeOf Item Is Outlook.MailItem Then
        If Left(Item.Subject, Len(SubToCheck)) = SubToCheck Then
            Me.CaptureWeatherInfo Item.Body
            MsgBox "Weather update complete for " & Item.Subject
        End If
    End If
End Sub

 

[jensen306]

Hi thanks for your reply but it does not work, it may be something that I forgot to set, I am brand new to VBA so I do not know very much about it.

 

[GWteB]

Hi thanks for your reply but it does not work, it may be something that I forgot to set, I am brand new to VBA so I do not know very much about it.

Prior to my previous post, I only had a superficial look at your code and the modification I suggested seemed the most obvious. The run-time error was object related and the only object that appeared in the PersonalInboxItems_ItemAdd event procedure was the Item object. I've now taken a closer look at your code and while one would expect the VBE to break where the actual error occurs, within Class modules the VBE usually does not. FYI, the ThisOutlookSession module is a Class module, otherwise you would never be able to intercept an Outlook event.

Now I've also looked at the CaptureWeatherInfo procedure and on a number of points things can go wrong here. The most striking point is that the code tries to obtain a reference of an already existing instance of Excel. If there's no such instance, the current code will fail. The On Error goto 0 re-enables the error handler but also clears the data of the last error that occurred. Because after that the Err object is queried, it will look like as if everything went well and a valid reference has been obtained, while that's not necessarily the case. I think this is the cause of your issue.

I've therefore revised this CaptureWeatherInfo procedure in its entirety. The code no longer checks whether an instance of Excel is already available, it immediately makes a new one available. I chose this approach for the following reason. If an Excel instance is already available, we don't know whether Excel can respond. Excel is not able to respond when it's in edit mode (when someone manually enters data in a worksheet range) and also when there's a modal Userform or another modal Dialog window on screen. This may generate a very long response time or (eventually) lead to an automation error. Either way, we don't want that.

Finally, I would like to note the following. Because the entire process now takes place entirely under the responsibility of Outlook VBA, there is a risk that not all data will be processed. This is because the process starts in response to an event. If the process is still running while the next event is taking place, there is a good chance that no new process will be started at that time.
You could therefore consider splitting tasks. If Outlook VBA were made solely responsible for flagging a new eligible email message, then the rest of the process could be run by Excel at any time. In this way the risk of missing messages is minimized.

Public Sub CaptureWeatherInfo(WeatherBody As String)

    Dim MSXL        As Object       ' Excel.Application
    Dim WeatherWB   As Object       ' Workbook

    Const WBPath = "C:\Users\bruger\OneDrive\Dokumenter\WEATHER REPORT\WEATHER REPORT FROM Vejr.xlsm"

    Set MSXL = CreateObject("Excel.Application") ' New Excel.Application
    With MSXL
        .Visible = True

Stop    ' <<<<< sets VBE in break mode so you're able to monitor the process by stepping through (using F8 key) <<<<<<

        Set WeatherWB = .Workbooks.Open(WBPath)
        GetWeatherInfo WeatherBody, WeatherWB.Sheets(2)
        WeatherWB.Save
        WeatherWB.Close False
        .Quit
    End With
    Set MSXL = Nothing
End Sub