Ir ao conteúdo
  • Cadastre-se
glauberpaiva

Ajuda - Macro (arquivo data+nome)

Recommended Posts

Galera, boa tarde!

Preciso de uma ajuda com uma macro.

Fiz a macro para um arquivo por enviar e-mail descritos na planilha.

Porém, o arquivo muda de nome todo o dia, salvo com a data atual.

Exemplo: 20130919_arquivo.pdf

(hoje 19/09/2013 o arquivo foi salvo com a data+nome)

Também preciso que a macro inclua a assinatura do outlook automaticamente do usuário que está enviando.

Sub Enviar_email()

Dim enderecos As Range

Dim celula As Range

Dim anexo As String

Dim r As Integer

Dim fim

Dim enviar

Dim objetoapp As Outlook.Application

Dim objOlAppMsg As Outlook.MailItem

Dim objOlAppRecip As Outlook.Recipient

Set objetoapp = CreateObject("Outlook.Application")

Set objOlAppMsg = objetoapp.CreateItem(olMailItem)

Set enderecos = Range("B3:B4")

With objOlAppMsg

For Each celula In enderecos

If celula.Text <> "" And InStr(1, celula.Text, "@") > 0 Then

Set objOlAppRecip = .Recipients.Add(celula.Text)

Select Case UCase(celula.Offset(0, 1).Text)

Case "CC"

objOlAppRecip.Type = olCC

Case ""

objOlAppRecip.Type = olBCC

Case "To"

objOlAppRecip.Type = olTo

End Select

End If

Next celula

If .Recipients.Count = 0 Then GoTo fim

anexo = Range("H3")

If Len(anexo) = 0 Then GoTo enviar

Dim anexos

anexos = Split(anexo, ";")

Dim i

For i = LBound(anexos) To UBound(anexos)

If Dir(anexos(i)) = "" Then

r = MsgBox("Anexo '" & anexos(i) & _

"'inexistente ou caminho invalido, " & _

"pretende enviar assim mesmo ? ", _

vbYesNo, _

"Erro na localização do anexo")

If r <> vbYes Then GoTo fim

Else

.Attachments.Add anexos(i)

End If

Next i

Dim olapp As Outlook.Application

Dim objMail As MailItem

Set olapp = Outlook.Application

'Create mail item

Set objMail = olapp.CreateItem(olMailItem)

enviar:

.Importance = olImportanceNormal

.Subject = "Teste Macro"

.HTMLBody = " <head> <font face= calibri> <p></p></font> </head><body><font face=Calibri></body></html>"

.Display

End With

fim:

Set objetoapp = Nothing

Set objOlAppMsg = Nothing

Set objOlAppRecip = Nothing

End Sub

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora





Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×