Data Extraction from long text

[ECEK]

To coin a British phrase..."This is getting on my tits!" Actually, on reflection, I'm sure this is used globally....especially by incompetent computer people like me !

OK....so.

My network will not allow me export my email list from Outlook so I have to select my groups in a new email, expand the list (to get each individual email address) then copy.

The paste results in a long continuous text string.
Example text:

Employee One | My Business <employee.one@mybusiness.co.uk>;Employee Two | My Business <employee.two@mybusiness.co.uk>;Employee Three | My Business <employee.three@mybusiness.co.uk>;

I want to paste this into a long text field and magically I am left with a table with my emails in it

employee.one@mybusiness.co.uk
employee.two@mybusiness.co.uk
employee.three@mybusiness.co.uk

What would be the best approach ?

 

[arnelgp]

create a Form bound to your table.
put an Unbound textbox on the form.
make the textbox large enough
so you can see it like a memo pad.
add a command button. on the click
event of the button, add this:


Private Sub button_Click()
Dim varSplit As Variant
Dim var As Variant
Dim strEmail As String
Dim strNewMail As String
strEmail = Trim(Me.UnboundTextboxName & "")
If strEmail <> "" Then
varSplit = Split(strMail, ";")
For Each var In varSplit
strNewMail = strNewMail & var & vbCrLF
Next
If Len(strNewMail)>0 Then
strNewMail = Left(strNewMail, Len(strNewMail)-2)
strNewMail = Trim(strNewMail)
Me.UnboundTextboxName = strNewMail
CurrentDb.Execute "Insert Into yourEmailTable (yourEmailFieldName) SELECT " & Chr(34) & strNewMail & Chr(34)
End Sub

'* end of code

check yourEmailTable if the email's are saved correctly.

 

[ECEK]

Block If without End If error

 

[arnelgp]

this is much better in the eyes

Private Sub button_Click()

    Dim varSplit As Variant
    Dim var As Variant
    Dim strEmail As String
    Dim strNewEMail As String
    
    strEmail = Trim(Me.UnboundTextBox & "")
    If strEmail <> "" Then
        varSplit = Split(strEmail, ";")
        For Each var In varSplit
            strNewEMail = strNewEMail & var & vbCrLf
        Next
        
        If Len(strNewEMail) > 0 Then
            strNewEMail = Left(strNewEMail, Len(strNewEMail) - 2)
        End If
        
        strNewEMail = Trim(strNewEMail)
        Me.UnboundTextBox = strNewEMail
        
        CurrentDb.Execute "INSERT INTO yourEmailTable (yourEmailFielName) SELECT " & Chr(34) & Me.UnboundTextBox & Chr(34)
    End If
End Sub

 

[ECEK]

lastest results:

On click the UnboundTextBox changes to list the names like so: Not correctly trimmed:

Employee One | My Business <employee.one@mybusiness.co.uk>
Employee Two | My Business <employee.two@mybusiness.co.uk>
Employee Three | My Business <employee.three@mybusiness.co.uk>

They also do not appear as individual records in the emailtable. They appear as they do on the form but in one record.

We need to correctly trim ie everything between < and > send it to the table THEN Next to repeat.

 

[arnelgp]

ok sister, this is the final code.
scrap the one i gave you.
we'll use RegExpression to do the trick.

Private Sub Command2_Click()
    
    Dim oRE, oMatches, oMatch
    
    Dim sPattern
    Dim varEmailPattern As String
    Dim var As Variant
    Dim strEmails As String
    
    sPattern = "\b[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}\b"
    
    
    Set oRE = CreateObject("VBScript.RegExp")
    With oRE
        .Global = True
        .IgnoreCase = True
    End With
    
    oRE.Pattern = sPattern
    Rem===============================================
    Rem
    Rem put the correct name of unbound textbox below
    Rem
    Rem===============================================
    Me.Text0.SetFocus
    Set oMatches = oRE.Execute(Me.Text0.Text)
    
    'Debug.Print "Matches: " & oMatches.Count
    For Each oMatch In oMatches
        strEmails = strEmails & Trim(CStr(oMatch)) & vbCrLf
        'Debug.Print Trim(CStr(oMatch))
        'Debug.Print String(oMatch.FirstIndex, " ") & String(oMatch.length, "^")
        Rem===================================================
        Rem
        Rem put the correct tablename and fieldname
        Rem
        Rem==================================================
        CurrentDb.Execute "INSERT INTO EmailExtraction (EmailAddress) SELECT " & Chr(34) & Trim(CStr(oMatch)) & Chr(34)
    Next
    
    Set oMatch = Nothing
    Set oMatches = Nothing
    Set oRE = Nothing
    If Len(strEmails) > 0 Then
        strEmails = Left(strEmails, Len(strEmails) - 2)
        
        Rem=========================================================
        Rem
        Rem put the correct name of unbound texbox
        Rem
        Rem=========================================================
        Me.Text0 = strEmails
    End If
End Sub

 

[ECEK]

The trimming worked but they are all ending up in one record as opposed to three.
It's as though the "Next" is in the wrong place.

My understanding would be to extract the data, send it to the table then repeat the exercise.

 

[arnelgp]

I have edited the code already, maybe you have downloaded the un edited version while i was editing it. Copy it again, dont let it got into your... You nake me laugh with that..

 

[ECEK]

Baldrick I love you !!

Arnie that is brilliant. I hope others can benefit from this.

 

[arnelgp]

Lol, enough, my stomach is cramping.