Solved: Search and Attach file to email using VBA

[nupema]

Hi to all!

I need help.. im desperate.. I have the above code already working...



Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = Sheets("Conteudo_Mail").Range("B4").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B5").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next
With OutMail
Select Case Range("K9").Value
Case Is = "LX"
.To = Range("C7").Value
.CC = Sheets("Conteudo_Mail").Range("C2").Value
.BCC = ""
.Subject = Range("M7").Value
.Body = Sheets("Conteudo_Mail").Range("C5").Value
Case Is = "PT"
.To = Range("C7").Value
.CC = Sheets("Conteudo_Mail").Range("C3").Value
.BCC = ""
.Subject = Range("M7").Value
.Body = Sheets("Conteudo_Mail").Range("C5").Value
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Send
MsgBox "E-mail Enviado"
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

A just need help with two more things please...

First:

I want to know how can I put a function to attach a file into the email, but need to search the file equal to a cell value and than if it is equal, attach the file to the email.

Something like: search pdf file named equal to text in F7 cell, and than attach.


Second:

And how can I apply the code to all lines, so i dont have to put 200 buttons (one for which line)?

Could anyone please help meeee....? I need this working :(

Thank you very very much.. :)

[mdmackillop]

This will look for a file in a specific location and attach it if found
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim Pth As String

Pth = "C:\AA\"

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = Sheets("Conteudo_Mail").Range("B4").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B5").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next
With OutMail
Select Case Range("K9").Value
Case Is = "LX"
.To = Range("C7").Value
.CC = Sheets("Conteudo_Mail").Range("C2").Value
.BCC = ""
.Subject = Range("M7").Value
.Body = Sheets("Conteudo_Mail").Range("C5").Value
.Attachments.Add Pth & Dir(Pth & Range("O7"))


Regarding the second part, it is not clear what cells you need to loop to send to different addresses. Can you post a sample layout? Make sure addresses are dummy ones.

[nupema]

mdmackillop, thank you very much for your help..! Really :thumb

Here is a identical file (hope you can help me).. :)

4830



:friends:

[nupema]

I forget to tell you.. the file name to be searched is equal to G7 cell (User KAI).

Best regards.

[mdmackillop]

This is based on your attachment to the best of my understanding
Option Explicit

Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim LRow As Long
Dim i As Long
Dim strBody As String

LRow = Cells(Rows.Count, 11).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next

With OutMail
For i = 7 To LRow
Select Case Range("K" & i).Value
Case Is = "LX"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B2").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
Case Is = "PT"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B3").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Display
MsgBox "E-mail Enviado - " & Range("D" & i).Value
Next
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

[nupema]

This is based on your attachment to the best of my understanding
Option Explicit

Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim LRow As Long
Dim i As Long
Dim strBody As String

LRow = Cells(Rows.Count, 11).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next

With OutMail
For i = 7 To LRow
Select Case Range("K" & i).Value
Case Is = "LX"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B2").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
Case Is = "PT"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B3").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Display
MsgBox "E-mail Enviado - " & Range("D" & i).Value
Next
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Where do I set directory to search the file corresponding the various "user NT" cell's?

And is there anyway to select (maybe some kind of check box's listed in front of the cell lines) to choose witch line I want to apply the vba code? Cause I need to do a weekly send, with just some lines (not all the lines).

Thank you, best regards.

[mdmackillop]

A select item "x" or other should be placed in Column A
Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim LRow As Long
Dim i As Long
Dim strBody As String
Dim Pth As String


Pth = "C:\AA\" '<==== Change to suit
LRow = Cells(Rows.Count, 11).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next

With OutMail
For i = 7 To LRow
If Cells(i, 1) <> "" Then '<====Change to suit
Select Case Range("K" & i).Value
Case Is = "LX"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B2").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
.Attachments.Add Pth & Dir(Pth & Range("G" & i) & ".pdf")
Case Is = "PT"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B3").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
.Attachments.Add Pth & Dir(Pth & Range("G" & i) & ".pdf")
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Display
MsgBox "E-mail Enviado - " & Range("D" & i).Value
End If
Next
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

[nupema]

Something is wrong..please look at the attach.

When sending mail to user's, x002, x003, x004.. this is what happen :banghead:

The only attached file on this case should be "user x002" file..

And the same happen's with x003 and x004 mails

[nupema]

The only thing i change in the vba code it was the compare name column.

The file name to attach should be equal to "L" collumn, not "G" as i tell you before... (sorry for that), my mistake..

And I can make the selection box's to work :dunno

[mdmackillop]

A little reordering
Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim LRow As Long
Dim i As Long
Dim strBody As String
Dim Pth As String


Pth = "C:\AA\" '<==== Change to suit
LRow = Cells(Rows.Count, 11).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)

strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next

For i = 7 To LRow
If Cells(i, 1) <> "" Then '<====Change to suit
Set OutMail = OutApp.CreateItem(0)
With OutMail
Select Case Range("K" & i).Value
Case Is = "LX"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B2").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
.Attachments.Add Pth & Dir(Pth & Range("L" & i) & ".pdf")
Case Is = "PT"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B3").Value
.BCC = ""
.Subject = Range("N" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value
.Attachments.Add Pth & Dir(Pth & Range("L" & i) & ".pdf")
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Display
End With
Set OutMail = Nothing
End If
Next

On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

[nupema]

Yes!!! Its working!! :rofl::rotlaugh:

One last help please.. and I promisse i stop being so annoying :whistle:

Im trying to get outlook signature in the emails, and for that trying to use this vba code:




Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim LRow As Long
Dim i As Long
Dim strBody As String
Dim Pth As String


Pth = "\\OPLX01DT1556\Npmartins\AQF\Avaliações\FEEDBACK_ASSISTENTES\Por_Enviar\" '<==== Alterar para o caminho dos PDF's
LRow = Cells(Rows.Count, 11).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)

strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf

On Error Resume Next

For i = 7 To LRow
If Cells(i, 1) <> "" Then '<====Alterar se necessário
Set OutMail = OutApp.CreateItem(0)
With OutMail
Select Case Range("K" & i).Value
Case Is = "LX"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B2").Value
.BCC = ""
.Subject = Range("O" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value & Assinatura
.Attachments.Add Pth & Dir(Pth & Range("L" & i) & ".pdf")
Case Is = "PT"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B3").Value
.BCC = ""
.Subject = Range("O" & i).Value
.Body = strBody 'Sheets("Conteudo_Mail").Range("B5").Value & Assinatura
.Attachments.Add Pth & Dir(Pth & Range("L" & i) & ".pdf")
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Display
End With
Set OutMail = Nothing
End If
Next

On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

'
' Função usada para tratar o pedido de inserção de assinatura
'
Function Assinatura()
Dim fAssinatura, stAssinatura, stLinha
fAssinatura = Environ("APPDATA") & "\Documents and Settings\(my user)\Application Data\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6")
stAssinatura = ""
If Dir(fAssinatura) <> "" Then
Open fAssinatura For Input As #1
Do While Not EOF(1)
Line Input #1, stLinha
stAssinatura = stAssinatura & vbCrLf & stLinha
Loop
Close #1
End If
Assinatura = stAssinatura
End Function





In Sheet "Conteudo_Mail" cell (B6) I put the file name like "signature.htm" but its not working.. Can you help? :think:

Best regards. :)

[mdmackillop]

Check out Ron de Bruin's site (http://www.rondebruin.nl/mail/folder3/signature.htm)

[nupema]

Check out Ron de Bruin's site (http://www.rondebruin.nl/mail/folder3/signature.htm)

Already try it yesterday.. and simple cant get it to work.. try with both examples.. :banghead:

[Bob Phillips]

Did you replace (my user) in this line>

fAssinatura = Environ("APPDATA") & "\Documents and Settings\(my user)\Application Data\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6")

Do you have a file extension in the cell value?

[nupema]

Did you replace (my user) in this line>

fAssinatura = Environ("APPDATA") & "\Documents and Settings\(my user)\Application Data\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6")

Do you have a file extension in the cell value?

Hi XLD. Thanks for help.

Yes, i replace (my user), with my windows account user, without bracket.

This is print screen from "Conteudo_Mail" excel sheet:

[Bob Phillips]

It's late here, so if you haven't got another response, I will take a look tomorrow.

[nupema]

It's late here, so if you haven't got another response, I will take a look tomorrow.

ok.. thank you! :thumb

[Bob Phillips]

When testing this out this morning, I found that



Environ("APPDATA")


returned the value

C:\Documents and Settings\Bob\Application Data

on my ststem (XP Sp3, XL 2007).

Your code is appending



"\Documents and Settings\(my user)\Application Data\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6")


to this, so your are doubling up the \Documents and Settings\Bob\Application Data part.

I suggest that you try



'
' Função usada para tratar o pedido de inserção de assinatura
'
Function Assinatura()
Dim fAssinatura, stAssinatura, stLinha
fAssinatura = Environ("APPDATA") & "\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6").Value2
stAssinatura = ""
If Dir(fAssinatura) <> "" Then
Open fAssinatura For Input As #1
Do While Not EOF(1)
Line Input #1, stLinha
stAssinatura = stAssinatura & vbCrLf & stLinha
Loop
Close #1
End If
Assinatura = stAssinatura
End Function

[nupema]

I suggest that you try



'
' Função usada para tratar o pedido de inserção de assinatura
'
Function Assinatura()
Dim fAssinatura, stAssinatura, stLinha
fAssinatura = Environ("APPDATA") & "\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6").Value2
stAssinatura = ""
If Dir(fAssinatura) <> "" Then
Open fAssinatura For Input As #1
Do While Not EOF(1)
Line Input #1, stLinha
stAssinatura = stAssinatura & vbCrLf & stLinha
Loop
Close #1
End If
Assinatura = stAssinatura
End Function

My system is also (XP Sp3, XL 2007).

Already try your sugestion, same behavior..:dunno

[Bob Phillips]

What do you mean, it appended the text 'signature.htm' to your email?

[nupema]

What do you mean, it appended the text 'signature.htm' to your email?

yes, that was a print of the generated e-mail.. "signature.htm" is the name of the signature file that is located in \microsoft\signature folder.

The generated e-mail should have the signature that is on signature.htm file:

[Bob Phillips]

What code are you using to add the signature.

BTW, the code doesn't match the image, there is nothing in A7 as the code looks for.

[Bob Phillips]

You didn't follow the instructions in Ron's code, you just inserted the value in B6 rather than decoding it.



Option Explicit

Sub Mail_small_Text_Outlook()
'Working in Office 2000-2010

Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim LRow As Long
Dim i As Long
Dim strBody As String
Dim Pth As String


Pth = "C:\Documents and Settings\Bob\My Documents\test\" '"\\OPLX01DT1556\Npmartins\AQF\Avaliações\FEEDBACK_ASSISTENTES\Por_Enviar\" '<==== Alterar para o caminho dos PDF's
LRow = Cells(Rows.Count, 11).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)

strBody = Sheets("Conteudo_Mail").Range("B5").Value & "<br><br>" & Assinatura

On Error Resume Next

For i = 7 To LRow
If Cells(i, 1) <> "" Then '<====Alterar se necessário
Set OutMail = OutApp.CreateItem(0)
With OutMail
Select Case Range("K" & i).Value
Case Is = "LX"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B2").Value
.BCC = ""
.Subject = Range("O" & i).Value
.HTMLBody = strBody 'Sheets("Conteudo_Mail").Range("B5").Value & Assinatura
.Attachments.Add Pth & Dir(Pth & Range("L" & i) & ".pdf")
Case Is = "PT"
.To = Range("D" & i).Value
.CC = Sheets("Conteudo_Mail").Range("B3").Value
.BCC = ""
.Subject = Range("O" & i).Value
.HTMLBody = strBody
.Attachments.Add Pth & Dir(Pth & Range("L" & i) & ".pdf")
Case Else
MsgBox "Não pode ser enviado"
Exit Sub
End Select
.Display
End With
Set OutMail = Nothing
End If
Next

On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

'
' Função usada para tratar o pedido de inserção de assinatura
'
Function Assinatura()
Dim fAssinatura, stAssinatura, stLinha
fAssinatura = Environ("APPDATA") & "\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6").Value2
stAssinatura = ""
If Dir(fAssinatura) <> "" Then
Open fAssinatura For Input As #1
Do While Not EOF(1)
Line Input #1, stLinha
stAssinatura = stAssinatura & vbCrLf & stLinha
Loop
Close #1
End If
Assinatura = stAssinatura
End Function

[nupema]

What code are you using to add the signature.

BTW, the code doesn't match the image, there is nothing in A7 as the code looks for.

Shouldn't this code add the signature?



'
' Função usada para tratar o pedido de inserção de assinatura
'
Function Assinatura()
Dim fAssinatura, stAssinatura, stLinha
fAssinatura = Environ("APPDATA") & "\Microsoft\Signatures\" & Sheets("Conteudo_Mail").Range("B6").Value2
stAssinatura = ""
If Dir(fAssinatura) <> "" Then
Open fAssinatura For Input As #1
Do While Not EOF(1)
Line Input #1, stLinha
stAssinatura = stAssinatura & vbCrLf & stLinha
Loop
Close #1
End If
Assinatura = stAssinatura
End Function

[Bob Phillips]

Well it would do if you used it, but your code was wrong in that function, you setup strBody like this



strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf


not using Assinatura, there was at least one version of your code that commented out the call to Assinatura, and you didn't use HTMLBody as Ron's code shows.

[nupema]

Well it would do if you used it, but your code was wrong in that function, you setup strBody like this



strBody = Sheets("Conteudo_Mail").Range("B5").Value & vbCrLf & _
vbCrLf & Sheets("Conteudo_Mail").Range("B6").Value & _
vbCrLf & vbCrLf & vbCrLf

not using Assinatura, there was at least one version of your code that commented out the call to Assinatura, and you didn't use HTMLBody as Ron's code shows.

hummm.. Any solution? :think:

[Bob Phillips]

Yes, I gave it to you in post #23 of this thread.

[nupema]

Yes, I gave it to you in post #23 of this thread.

Ops.. that one pass me.. :banghead:

but its working!! :rofl:

The only thing, is that my signature have a logo pic included that dont appear:

[Bob Phillips]

Presumably the image is not available to the boilerplate definition.

[nupema]

I think there is some kind of vba solution to do this...?! but I use this HTML solution, and its working..:clap:

Just put this line in the end of body text:

<img src="C:\Documents and Settings\user\Application Data\Microsoft\Signatures\image.jpg " />

But just for curiosity, what is the "boilerplate" you refer. And how can be "solved"?

[Bob Phillips]

Boilerplate, your Assinatura function, that is the one that builds the signature HTML.

I should have realised the image was in the signatures area.

The Thread Tools dropdown at the to of the thread is where you mark it solved.

[nupema]

mdmackillop and xld, thank you very much to both!! :friends:

You guys are the best! :beerchug: