How extract email address from Word document using vba

My goal is to extract all email addresses from the Word.ActiveDocument and put them into one single cell in the Excel Sheet.

The code is run from Excel VBA editor. It needs to search for email addresses, extract them from the document and fill the Excel cell Activesheet.Range("C31"). Only one cell is available, no matter how many email addresses have been found.

The addresses found need to be delimited using ", " the coma and the space.

I'm trying to do this by finding @ in the document and then building up the range forward and backwards to have all the email address in the range variable. Building the address to the right was quite easy using rng.MoveEndUntil Cset:="," because in my document there is always a coma after the email address.

But how to get the missing left side of the email address into the range variable?? I've used rng.MoveStart Unit:=wdWord, Count:=-1 but what if the email will be romek.zjelonek@wp.com or grawer.best@yahoo.com It will not work.

This is what I have now.

Sub FindEmail035()         '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
                           '[0-9;A-z;,._-]{1;}\@[0-9;A-z;._-]{1;}
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim ExcelApp As Excel.Application

Dim rng As Word.Range
Dim emailAdr As String
Dim ws As Worksheet

Set WordApp = GetObject(, "Word.Application")
Set ExcelApp = GetObject(, "Excel.Application")
Set WordDoc = WordApp.ActiveDocument
Set rng = WordApp.ActiveDocument.Content
Set ws = ExcelApp.ActiveSheet

ExcelApp.Application.Visible = True

    With rng.Find
        .Text = "@"
        .Wrap = wdFindAsk
        .Forward = True
        .MatchWildcards = False
        .Execute

        Debug.Print rng.Text
        If .Found = True Then
            'rng.Expand (wdWord)
            'Debug.Print rng.Text
            rng.MoveStart Unit:=wdWord, Count:=-1
            Debug.Print rng.Text
            rng.MoveEndUntil Cset:=","'rng.MoveEnd Unit:=wdWord, Count:=1
            'rng.MoveEndUntil Cset:="", Count:=wdBackward
        End If
   End With     'how to create loop that will extract all the email addresses in the document??
   ws.Range("C31").Value = rng

End Sub

What loop should I use to get the number of mails present in the document and later build up the ranges with email addresses inside?

This is the place in the document where the mail addresses reside.