Colegas, tudo beleza...
Preciso de ajuda para melhorar o meu código VBA abaixo. Ele está funcionando normalmente, porém, gostaria de algumas melhorias, vou explicar o que ele faz e depois o que quero melhorar:
A função principal dele é enviar (via Outlook) mala direta para uma lista de e-mails que tem nesta planilha.
Então, o excel tem duas abas, uma chamada “Menu” que tem o botão que dispara a execução da Macro, e a outra aba chamada “Dados” que nesta tem os dados que compõem o e-mail como: e-mail do destinatário, Assunto e Texto do Corpo e o caminho do arquivo que será anexado ao e-mail.
Criei esta macro pois, no meu trabalho, tenho que enviar um relatório de vendas individualmente pra cada vendedor externo. Como é algo muito repetitivo, criei esta macro que cria o e-mail, anexa o arquivo, preenche os dados de cada vendedor e dispara o e-mail automaticamente.

Melhorias necessárias:
Toda execução ocorre em segundo plano, então só sei se terminou quando exibe a MsgBox no final de tudo, se caso algo travar não vou acompanhar.
1ª melhoria: Seria criar uma barra de status (ou progressão) para ir acompanhando o estágio de execução de 0% a 100% por exemplo.
2ª melhoria: Criar mais um campo para o Conteúdo do Corpo do e-mail, pois hoje, ele está levando para o corpo do e-mail o que está dentro da célula que tem o Assunto.

Alguém me ajuda com essas duas melhorias.? Não estou conseguindo sozinho.
Segue abaixo o Código VBA e o excel para visualizarem melhor.

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim strEmail As String, strName As String
Dim lRowCount As Long

Set objOutlook = CreateObject("outlook.application")
Sheets("Dados").Select 'Seleciona a pasta "Dados".
lRowCount = 2
Do Until ActiveSheet.Cells(lRowCount, 2) = ""
strEmail = ActiveSheet.Cells(lRowCount, 2).Value
strName = ActiveSheet.Cells(lRowCount, 1).Value
Set objOutlookMsg = objOutlook.CreateItem(olMailItem) 
With objOutlookMsg
.Subject = ActiveSheet.Cells(lRowCount, 3).Value ' Note: Could be Column "C" - ActiveSheet.Cells(lRowCount, 3).Value
.Body = ActiveSheet.Cells(lRowCount, 3).Value ' Note: Could be Column "D" - ActiveSheet.Cells(lRowCount, 4).Value
.To = strEmail
'.Attachments.Add ("c:/e-mail attachments/" & strName & ".xls")
.Attachments.Add (ActiveSheet.Cells(lRowCount, 4).Value)
.Send
End With
lRowCount = lRowCount + 1 ' Increment Row Counter
Loop
Sheets("Menu").Select
Range("C3").Select
MsgBox (" E-mails enviados com Sucesso! "), vbInformation, "Envio Automático dos E-mails."
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
End Sub