Remove os nomes do meio, preservando os primeiros e o último nome

Inspirado nesse tópico: https://www.maximoaccess.com/t42091-vba-extrair-nome-apelido-e-nomes-do-meio
apresento-lhes uma função que retorna os primeiros nomes e o último e remove as preposições. Exemplo:
Nome: Maria Eugénia do Carmo Mendonça Teixeira Fernandes - possui 50 caracteres.

Mas quero que seja reduzido para apenas 30 caracteres, preservando os primeiros nomes e o último, ficando assim:

Mara Eugénia Carmo Fernandes.

Basta aplicar a função:

ReduzNomes("Maria Eugénia do Carmo Mendonça Teixeira Fernandes", 30)

Será retornado: Mara Eugénia Carmo Fernandes

Notem que a quantidade de caracteres pode ser a que vocês determinarem no parâmetro. Nesse exemplo foi 30.

Obs.: A função também trata espaços vazios, deixando apenas um espaço entre palavras e remove espaços do inicio e fim.

E como se trata de uma função publica, poderá utilizar inclusive em uma consulta.

Código:

'Autor: Marcelo David
'Data: 31/05/2023
'Propósito: Reduz um nome para uma quantidade definida de caracteres, preservando palavras completas e
'e sempre retornando os primeimeiros nomes e o último nome/palavra
'----------------------------------------------------------------------------------
'Parâmetros -----------------------------------------------------------------------
'strNome: o nome que será reduzido
'iQuantidadeCaracteres: o limite máximo de caracteres que será retornado
'Exemplo: -------------------------------------------------------------------------
'No nome "Marcelo Rocha Vascocelos Romero dos Santos Consta David", que possue 55 caracteres e eu deseje
'retonar até 25 caracteres, basta chamar a função passando para uma variável ou qualquer outro objeto.
'Nesse exemplo, quero passar o retorno para uma Caixa de Texto (TextBox) chamada TxtNome:
'Me.TxtNome = ReduzNomes("Marcelo Rocha Vascocelos Romero dos Santos Consta David", 25)
'A Caixa de texto receberá: Marcelo Rocha David, pois há 19 caracteres e o próxim nome já passaria dos
'25 caracteres definidos
Public Function ReduzNomes(strNome As String, iQuantidadeCaracteres As Integer) As String
   Dim vNomes() As String
   Dim i As Integer
   Dim r As String
   Dim ra As String
   
   'Removo espaços a direita e esquerda
   strNome = Trim(strNome)
   
   'Já passo a atrubuo o valor do pamêtro strNome para a função, assim mesmo que a quantidade de caracteres
   'seja igual ou menos que iQuantidadeCaracteres a função terá valor
   ReduzNomes = strNome

   'Caso o nome tenha até quantidade definida em iQuantidadeCaracteres, não executa a sub
   If Len(strNome) <= iQuantidadeCaracteres Then Exit Function

   'Separo os nomes
   vNomes = Split(strNome)
   'Percorro os elementos da matriz (nomes) para montar o nome final
   For i = LBound(vNomes) To UBound(vNomes)
       'Só incluo nomes e não preposição
       If vNomes(i) <> "dos" And vNomes(i) <> "do" And vNomes(i) <> "da" And vNomes(i) <> "das" And vNomes(i) <> "de" And vNomes(i) <> "e" And Not IsEmpty(vNomes(i)) Then
           ra = Trim(ra) & " " & vNomes(i)
           If Len(ra & " " & vNomes(UBound(vNomes))) <= iQuantidadeCaracteres Then
               r = Trim(ra) & " " & vNomes(UBound(vNomes))
           End If
       End If
   Next
   ReduzNomes = r
End Function

Parabéns
Será útil com certeza.

Parabéns, Marcelo David!

A função está excelente!

Vai ajudar muita gente!


Vou pedir a sua ajuda no tópico original.

Marcelo, volto a agradecer o excelente trabalho realizado.

Muito Obrigado!

Olá Marcelo David,

Parabéns pelo exemplo e partilha "do desafio"

Abraço