Populating the subject line of an email with the first line of its body

Question

The team at my office spends a lot of time copying and pasting the first line of an article in the body and pasting it in the subject line.

I have found a solution that takes the first line of the body and sets it as the subject.

The problem is that there are always two-three blank lines above the first line of text in the body. The solution still works but it sets the subject as " ".

Is there a way to either delete the empty lines at the top, or skip over them and set the subject as being the first line of text (excluding white spaces)?

Thank you in advance for your help, you would really help the team and make an intern (me) very happy.

Many thanks to Shirley Zhang from DataNumen who provided the code.

Here is the VBA code I have been using:

Private WithEvents objInspectors As Outlook.Inspectors

Private Sub Application_Startup()
   Set objInspectors = Outlook.Application.Inspectors
End Sub

Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
    If Inspector.CurrentItem.Class = olMail And Inspector.CurrentItem.subject = "" Then
       Inspector.CurrentItem.subject = " "
    End If
End Sub

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMail As Outlook.MailItem
Dim objMailDocument As Word.Document
Dim objMailSelection As Word.Selection

If TypeOf Item Is MailItem Then
   Set objMail = Item

   If Len(Trim(objMail.subject)) = 0 Then
         Set objMailDocument = objMail.GetInspector.WordEditor
         Set objMailSelection = objMailDocument.Application.Selection

         objMailDocument.Range(0, 0).Select
         objMailSelection.MoveEnd wdLine

         'Take first line of body as subject
         objMail.subject = objMailSelection.Text
   End If
 End If
End Sub

Answer 1

Give this a shot:

If TypeOf Item Is MailItem Then
   Set objMail = Item

   If Len(Trim(objMail.Subject)) = 0 Then
       Set objMailDocument = objMail.GetInspector.WordEditor
       Set objMailSelection = objMailDocument.Application.Selection

       objMailDocument.Range(0, 0).Select
       objMailSelection.MoveEnd wdLine

       'Loop until we find some text
       Do While objMailSelection.Text = ""
          objMailSelection.MoveEnd wdLine
       Loop

       'Take first line of body as subject
       objMail.Subject = objMailSelection.Text
   End If
End If

Answer 2

Have you tried using Regular Expression (regex or regexp for short)

https://regex101.com/r/msJ13L/2

---

 "^\\w(.*)$"

^ asserts position at start of a line

\\w matches any word character (equal to [a-zA-Z0-9_])

1st Capturing Group (.*)

.* matches any character (except for line terminators)

* Quantifier — Matches between zero and unlimited times, as many times as possible, giving back as needed (greedy)

$ asserts position at the end of a line Global pattern flags

m modifier: multi line. Causes ^ and $ to match the begin/end of each line (not only begin/end of string)

---

VBA Example

Option Explicit
Public Sub Example()
    Dim Matches As Variant        
    Dim Item As MailItem
    Set Item = ActiveExplorer.selection(1)

    Dim RegExp As Object
    Set RegExp = CreateObject("VbScript.RegExp")

    Dim Pattern As String
    Pattern = "^\w(.*)$"
    With RegExp
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = Pattern
         Set Matches = .Execute(Item.Body)
    End With

    If Matches.Count > 0 Then
        Debug.Print Matches(0) ' Print on Immediate Window
    Else
        Debug.Print "Not Found "
    End If

    Set RegExp = Nothing
End Sub

Answer 3

Try this:

If Len(Trim(objMail.subject)) = 0 Then
     'Take first line of body as subject
     objMail.subject = FirstLineOfText(objMail.GetInspector.WordEditor)
End If

Function to return first line of text:

Function FirstLineOfText(doc As Word.Document)
    Dim p As Word.Paragraph, rng
    For Each p In doc.Paragraphs
        'Find the first paragraph with content
        If Len(p.Range.Text) > 2 Then
            'select the start point of the paragraph
            doc.Range(p.Range.Start, p.Range.Start).Select
            'extend the selection to include the whole line
            doc.Application.Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            FirstLineOfText = Trim(doc.Application.Selection.Text) '<<EDITED
            Exit Function
        End If
    Next p
End Function