Skip to content

Commit

Permalink
separation of concerns (#22)
Browse files Browse the repository at this point in the history
  • Loading branch information
@Mo-Gul
Mo-Gul authored Nov 24, 2021
1 parent e4de073 commit 2a4b859
Show file tree
Hide file tree
Showing 4 changed files with 846 additions and 777 deletions.
344 changes: 1 addition & 343 deletions QuoteFixMacro.bas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,9 +98,6 @@ Private Const DEFAULT_QUOTING_TEMPLATE As String = "(Reply inline - powered by h
'English quote template
Private Const DEFAULT_QUOTING_TEMPLATE_EN As String = "(Reply inline - powered by https://macros4outlook.github.io/quotefixmacro/)\n\n%SN wrote on %D:\n\n%Q\n\nCheers"

'Last names may contain formal suffixes. If they are included here, they can be stripped.
Private Const LASTNAME_SUFFIXES As String = _
"II/III/IV/Jr/Jr./Sr/Sr./Esq."
'--------------------------------------------------------
'*** Configuration of condensing ***
'--------------------------------------------------------
Expand Down Expand Up @@ -1025,335 +1022,11 @@ Private Function getSenderEmailAddress(ByVal senderEmailType As String, ByVal se
getSenderEmailAddress = senderEmail
End Function

Private Function IsUpperCaseChar(ByVal c As String) As Boolean
IsUpperCaseChar = c Like "[A-Z]"
End Function

Public Function IsUpperCaseWord(ByVal word As String) As Boolean
IsUpperCaseWord = word Like "[A-Z][A-Z]*"
End Function

'NOTE: not used --> delete it?
Private Function IsWordCased(ByVal word As String) As Boolean
IsWordCased = (word Like "[A-Z][a-z]*") Or (word Like "[A-Z][a-z]*-[A-Z][a-z]*")
End Function

Private Function FixCase(ByVal word As String) As String
If Len(word) = 0 Then
FixCase = word
Exit Function
End If

Dim parts() As String
parts = Split(word, "-")

Dim i As Long
For i = LBound(parts) To UBound(parts)
Dim result As String
result = result & UCase$(Left$(parts(i), 1)) & LCase$(Mid$(parts(i), 2)) & "-"
Next

FixCase = Left$(result, Len(result) - 1)
End Function


'Attempts to extract the name of the sender from the sender's name provided in the email.
'
'Comment:
' This is very difficult to do definitively. Consider how many different variations
' and arrangements a name like "Dr. John James Walker Smith III" could entail including
' questions of first vs. last names, initials, titles, suffixes, etc..
'
'In:
' originalName - name as presented by Outlook
'Out:
' senderName - complete name of sender
' firstName - first name of sender
' lastName - last name of sender
' senderEmailAddress - sender email address (optional because of tests)
'Notes:
' * Public to enable testing
' * Names are returned by reference
Public Sub getNamesOutOfString(ByVal originalName As String, ByRef senderName As String, ByRef firstName As String, ByRef lastName As String, Optional ByRef senderEmailAddress As String = vbNullString)
'Find out firstName

Dim tmpName As String
tmpName = originalName

'cleanup quotes: if name is enclosed in quotes, just remove them
If (Left$(tmpName, 1) = """" And Right$(tmpName, 1) = """") Then
tmpName = Mid$(tmpName, 2, Len(tmpName) - 2)
End If

'default full senderName: originalName without quotes
senderName = tmpName

'default firstName: fullname
firstName = tmpName

Dim title As String
title = vbNullString
'Has to be later used for extracting the last name

tmpName = removeDepartment(tmpName)

If (Left$(tmpName, 4) = "Dr. ") Then
tmpName = Mid$(tmpName, 5)
title = "Dr. "
ElseIf (Right$(tmpName, 5) = ", Dr.") Then
tmpName = Left$(tmpName, Len(tmpName) - 5)
title = "Dr. "
ElseIf (Right$(tmpName, 3) = "Dr.") Then
tmpName = Left$(tmpName, Len(tmpName) - 3)
title = "Dr. "
End If

'Some companies have "(Text)" at the end of their name.
'We strip that
If (Right$(tmpName, 1) = ")") Then
Dim fPos As Long
fPos = InStrRev(tmpName, "(")
If fPos > 0 Then
tmpName = Trim$(Left$(tmpName, fPos - 1))
End If
End If

fPos = InStr(tmpName, ",")
If fPos > 0 Then
'Firstname is separated by comma and positioned behind the lastname
firstName = Trim$(Mid$(tmpName, fPos + 1))
'Firstname field may include middle initial(s)
Do While (UCase$(Right$(firstName, 2)) Like " [A-Z]" Or UCase$(Right$(firstName, 2)) Like "[A-Z].")
firstName = Trim$(Left$(firstName, Len(firstName) - 2))
Loop
lastName = Trim$(Left$(tmpName, fPos - 1))
'lastName field may have a formal suffix
lastName = StripSuffixes(lastName)
Else
'Determining first and last name is really hard unless
'there are only two names, or there is a middle initial(s)
fPos = InStr(Trim$(tmpName), " ")
If fPos > 0 Then
'First strip any possible, (single,) formal suffix on the name
tmpName = StripSuffixes(tmpName)
Dim lPos As Long
lPos = InStrRev(Trim$(tmpName), " ")
If fPos = lPos Then
'single first name and last name separated by space
firstName = Trim$(Left$(tmpName, fPos - 1))
lastName = Trim$(Mid$(tmpName, lPos + 1))
If firstName = UCase$(firstName) And Not lastName = UCase$(lastName) Then
'in case the firstName is written in uppercase letters (and not everything in capital letters),
'we assume that the sender's last name is the firstName (in the string)
lastName = firstName
firstName = Trim$(Mid$(tmpName, lPos + 1))
End If
Else
'middle section could be a single/multiple name/initial (or both)
Dim midName As String
midName = Trim$(Mid$(Left$(tmpName, lPos), fPos))

'One or two initials are easy
Do While Len(midName) = 1 Or _
Left$(midName, 1) = "." Or _
Left$(midName, 2) Like "[A-Z] " Or _
Left$(midName, 2) Like "[A-Z]."
midName = Trim$(Mid$(midName, 2))
Dim i As Long
i = i + 1
Loop
Do While Right$(midName, 2) Like " [A-Z]" Or _
Right$(midName, 2) Like "[A-Z]."
midName = Trim$(Left$(midName, Len(midName) - 2))
Dim j As Long
j = j + 1
Loop

If Len(midName) = 0 Then
'initials only
firstName = Trim$(Left$(tmpName, fPos - 1))
lastName = Trim$(Mid$(tmpName, lPos + 1))
ElseIf i <> 0 And j = 0 Then
'initials before double last name
lastName = midName & Trim$(Mid$(tmpName, lPos + 1))
firstName = Trim$(Left$(tmpName, fPos - 1))
ElseIf i = 0 And j <> 0 Then
'initials after double first name
lastName = Trim$(Mid$(tmpName, lPos + 1))
firstName = Trim$(Left$(tmpName, fPos - 1)) & midName
ElseIf Left$(midName, 1) = LCase$(Left$(midName, 1)) Then
'Midname starts with a lower case letter
'We assume "correct" casing. Thus, we hit a name such as Firstname von Lastname
firstName = Trim$(Left$(tmpName, fPos - 1))
lastName = Trim$(Mid$(tmpName, fPos + 1))
Else
'anything else can't be definitively identified as a first, middle or last name
firstName = tmpName
lastName = vbNullString
End If
End If
Else
fPos = InStr(tmpName, "@")
If fPos > 0 Then
'first name is (currently) an email address. Just take the prefix
tmpName = Left$(tmpName, fPos - 1)
End If
fPos = InStr(tmpName, ".")
If fPos > 0 Then
'first name is separated by a dot
lastName = Mid$(tmpName, fPos + 1)
tmpName = Left$(tmpName, fPos - 1)
Else
'name is a single string, without "." or " "
'final guess: LastnameFirstname
If (IsUpperCaseChar(Left$(tmpName, 1))) Then
i = 2
Dim UpperCaseCharCount As Long
UpperCaseCharCount = 0
Dim LastUpperCaseCharPos As Long
LastUpperCaseCharPos = 0
Do While (i < Len(tmpName) And (UpperCaseCharCount < 2))
If (IsUpperCaseChar(Mid$(tmpName, i, 1))) Then
LastUpperCaseCharPos = i
UpperCaseCharCount = UpperCaseCharCount + 1
End If
i = i + 1
Loop
If (UpperCaseCharCount = 1) Then
'LastnameFirstname format found
tmpName = Mid$(tmpName, LastUpperCaseCharPos)
End If
End If
End If
firstName = tmpName
End If
End If

Dim fnEmail As String
Dim lnEmail As String
getFirstNameLastNameOutOfEmail senderEmailAddress, fnEmail, lnEmail
If (LCase$(firstName) = LCase$(lnEmail)) And (LCase$(lastName) = LCase$(fnEmail)) Then
' in case firstname and lastname are reversed in the email address, we assume that email format is firstname.lastname and reverse the names here
Dim tmp As String
tmp = firstName
firstName = lastName
lastName = tmp
End If

'fix casing of names
If InStr(firstName, " ") = 0 Then
firstName = FixCase(firstName)
End If
If InStr(lastName, " ") = 0 Then
lastName = FixCase(lastName)
End If
senderName = title & Trim$(firstName & " " & lastName)
lastName = title & lastName
End Sub

Public Sub getFirstNameLastNameOutOfEmail(ByVal email As String, ByRef firstName As String, ByRef lastName As String)
If Len(email) = 0 Then
firstName = vbNullString
lastName = vbNullString
Exit Sub
End If
Dim parts() As String
parts = Split(email, "@")
Dim addressee As String
addressee = parts(0)
parts = Split(addressee, ".")

Dim length As Long
length = UBound(parts) - LBound(parts) + 1

If (length <> 2) Then
firstName = addressee
lastName = vbNullString
Exit Sub
End If
firstName = parts(LBound(parts))
firstName = stripNumbers(firstName)
lastName = parts(UBound(parts))
lastName = stripNumbers(lastName)
End Sub

Private Function stripNumbers(ByVal s As String) As String
Dim result As String
result = s
Do While (Right$(result, 1) Like "#")
result = Left$(result, Len(result) - 1)
Loop
stripNumbers = result
End Function


Public Function removeDepartment(ByVal tmpName As String) As String
Dim parts() As String
parts = Split(tmpName, " ")

Dim length As Long
length = UBound(parts) - LBound(parts) + 1

If length <= 2 Then
removeDepartment = tmpName
Exit Function
End If

Dim indexWordBeforeLastUppercasedWord As Long
indexWordBeforeLastUppercasedWord = UBound(parts)
Do While (indexWordBeforeLastUppercasedWord >= LBound(parts) + 2)
If Not IsUpperCaseWord(parts(indexWordBeforeLastUppercasedWord)) Then
Exit Do
End If
indexWordBeforeLastUppercasedWord = indexWordBeforeLastUppercasedWord - 1
Loop

If indexWordBeforeLastUppercasedWord < LBound(parts) + 1 Then
removeDepartment = tmpName
Exit Function
End If

Dim i As Long
For i = LBound(parts) To indexWordBeforeLastUppercasedWord
Dim result As String
result = result & parts(i) & " "
Next
removeDepartment = Left$(result, Len(result) - 1)
End Function


'Extracts the name of the sender from the sender's name provided in the email.
'TODO: Future work is to extract the first name out of the stored Outlook contacts (if that contact exists)
'
'Notes:
' * Names are returned by reference
Private Sub getNamesFromMail(ByVal item As MailItem, ByRef senderName As String, ByRef firstName As String, ByRef lastName As String)

'Wildcard replacements
senderName = item.SentOnBehalfOfName

If Len(senderName) = 0 Then
senderName = item.senderName
End If

getNamesOutOfString senderName, senderName, firstName, lastName, item.senderEmailAddress
End Sub

'Code duplication of getNamesFromMail, because there is no common ancestor of MailItem and MeetingItem
Private Sub getNamesFromMeeting(ByVal item As MeetingItem, ByRef senderName As String, ByRef firstName As String, ByRef lastName As String)

'Wildcard replacements
' `MeetingItem.SentOnBehalfOfName` not supported in Outlook 2019.
' Thus, we fall back to `senderName`.
senderName = item.senderName

If Len(senderName) = 0 Then
senderName = item.senderName
End If

getNamesOutOfString senderName, senderName, firstName, lastName, item.senderEmailAddress
End Sub


Private Function getOutlookHeader(ByRef BodyLines() As String, ByRef lineCounter As Long, ByRef MailMode As ReplyType) As String
' parse until we find the header finish "> " (Outlook_Headerfinish)

Expand Down Expand Up @@ -1613,18 +1286,3 @@ Public Sub DisplayMailItemByID(ByVal id As String)
it.Display
Set it = Nothing
End Sub

Private Function StripSuffixes(ByVal tempName As String) As String
'Create array of possible suffixes
Dim NameSuffixesArr() As String
NameSuffixesArr = Split(LASTNAME_SUFFIXES, "/")

'Strip the last suffix (is it ever the case that someone has multiple suffixes?)
Dim i As Long
For i = LBound(NameSuffixesArr) To UBound(NameSuffixesArr)
If (Right$(tempName, Len(NameSuffixesArr(i)) + 1)) = " " & NameSuffixesArr(i) Then
StripSuffixes = Trim$(Left$(tempName, Len(tempName) - Len(NameSuffixesArr(i))))
End If
Next
StripSuffixes = tempName
End Function
Loading

0 comments on commit 2a4b859

Please sign in to comment.