VBA Email from within Excel got it kinda working but...

[DipDip]

Hiya All,
I have spent hours looking over the net trying to get this to work but can't seem to figure it out. What I have is a daily meeting notes page that I fill in everyday in our meetings. This is on sheet 1. I have managed to work out how to convert this page to PDF then send out to a pre-specified list that was kept within the code. However, I have realised that it needs to be a dynamic list as people leave and new people start etc.

I have got the following to kinda work. My issue is that it stops at the third person, due to the gap. However, I would like to keep these gaps as they will get filled once we have filled all vacancies.

Any help would be greatly appreciated and many thanks in advance for anything you can suggest.

On the second sheet, I have the following setup:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Manager@hotmail.com[/TD]
[TD]Bob[/TD]
[TD]Manager[/TD]
[/TR]
[TR]
[TD]Clinicallead@hotmail.com[/TD]
[TD]Jane[/TD]
[TD]Clinical Lead[/TD]
[/TR]
[TR]
[TD]nurse1@hotmail.com[/TD]
[TD]Sarah[/TD]
[TD]Nurse 1[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Nurse 2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Nurse 3[/TD]
[/TR]
[TR]
[TD]LeadHCA@hotmail.com[/TD]
[TD]Stefani[/TD]
[TD]Lead HCA[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Senior HCA[/TD]
[/TR]
[TR]
[TD]me@hotmail.com[/TD]
[TD]Dipam[/TD]
[TD]Finance[/TD]
[/TR]
[TR]
[TD]hr@hotmail.com[/TD]
[TD]Tracy[/TD]
[TD]HR[/TD]
[/TR]
</tbody>[/TABLE]

Here is my code:

Sub Email()
'
Dim PDF As String
ChDir "C:\Meetings\"
strDate = Format(Date, "ddmmyy")
PDF_File = "Meeting " & strDate & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDF_File, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False


Sheet2.Activate


Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim myAttachments As Object
Dim strTo$
Dim strToFinal
Dim i%
strTo = "": i = 1


Do
strTo = strTo & Cells(i, 1).Value & "; "
i = i + 1
Loop Until IsEmpty(Cells(i, 1))
strToFinal = Mid(strTo, 1, Len(strTo) - 2)


Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set myAttachments = OutLookMailItem.Attachments


With OutLookMailItem
.To = strToFinal
.Subject = "Today's Meeting Notes"
.Body = "Hi All," & vbLf & vbLf _
& "Please find the notes from today's meeting" & vbLf & vbLf _
& "Regards" & vbLf & vbLf _
& "" & vbLf & vbLf _
& "" & vbLf _
& "Dipam" & vbLf _
& "Finance" & vbLf _
& "http://www.mywork.com/"




myAttachments.Add "C:\Meetings\" & PDF_File
.display
End With


Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
       
Kill "C:\Meetings\" & PDF_File


Sheet1.Activate


End Sub

Cheers again

Dipam

 

[GiorgiPepe]

hello,

looks like your code has problem at Do Loop:

Loop Until IsEmpty(Cells(i, 1))

instead you could use for each loop:
1)find last cell that is filled with ( Cells(rows.count,1).end(xlup).row
2) set range LoopRng = range("A1",cells(LastRow,1))
3) then do loop for each cell in LoopRng;
4) in loop include if cell is empty to jump to next: if isempty(cell) then next cell

think it might help

 

[DipDip]

Thanks for that. I've tried looking into what you advised, but I am not getting anywhere. Probably because I don't fully understand it all and try my best to figure stuff out as I go along.

This is what I have so far from what you said and then trying to google how to implement it...

Dim LastRow As Long
    With Worksheet.Sheet2
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
Set looprng = Range("A1", Cells(LastRow, 1))


Do
strTo = strTo & Cells(i, 1).Value & "; "
i = i + 1
For Each cell In looprng
Loop Until IsEmpty(cell)
Next cell
strToFinal = Mid(strTo, 1, Len(strTo) - 2)

 

[DipDip]

Anybody able to help me with this??? Pretty please

 

[GiorgiPepe]

Sub Email()'
Dim PDF As String
ChDir "C:\Meetings\"
strDate = Format(Date, "ddmmyy")
PDF_File = "Meeting " & strDate & ".pdf"
    
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDF_File, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False




Sheet2.Activate




Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim myAttachments As Object
Dim strTo$
Dim strToFinal
Dim i%
strTo = "": i = 1
Dim LCell As Range
Dim LoopRng As Range
Dim Cell As Range




Set LCell = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp)
Set LoopRng = Sheet2.Range("A1", LCell)




For Each Cell In LoopRng
    If IsEmpty(Cell) = True Then
        GoTo JumpHere
    Else
        strTo = strTo & Cells(i, 1).Value & "; "
        i = i + 1
    End If
JumpHere:
Next Cell


strToFinal = Mid(strTo, 1, Len(strTo) - 2)




Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set myAttachments = OutLookMailItem.Attachments




With OutLookMailItem
.To = strToFinal
.Subject = "Today's Meeting Notes"
.Body = "Hi All," & vbLf & vbLf _
& "Please find the notes from today's meeting" & vbLf & vbLf _
& "Regards" & vbLf & vbLf _
& "" & vbLf & vbLf _
& "" & vbLf _
& "Dipam" & vbLf _
& "Finance" & vbLf _
& "http://www.mywork.com/"








myAttachments.Add "C:\Meetings\" & PDF_File
.display
End With




Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
       
Kill "C:\Meetings\" & PDF_File




Sheet1.Activate




End Sub

Try This one

 

[DipDip]

Managed to figure this out with such a simple method. Highlighted the key bits in BOLD.

Just change the sheet name email to the name of the sheet where the email addresses are kept, and the range to the range in your worksheet. It ignores blanks and just adds in what is relevant.

Sub Email()
'
   
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim myAttachments As Object

Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
Set myAttachments = OutLookMailItem.Attachments


With Worksheets("Email")
        EmailTo = Join(Application.Transpose(.Range("C6:C23").Value), ";") & ";"
    End With

With OutLookMailItem
.To = EmailTo
.Subject = "Today's Meeting Notes"
.Body = "Hi All," & vbLf & vbLf _
& "Please find the notes from today's meeting" & vbLf & vbLf _
& "Regards" & vbLf & vbLf _
& "" & vbLf & vbLf _
& "" & vbLf _
& "Dipam"

.send
End With


Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
       
End Sub

 

[Paul Ked]

Put:

    For i = 1 To 9
        strTo = strTo & Cells(i, 1).Value & "; "
    Next

in place of:

Do
strTo = strTo & Cells(i, 1).Value & "; "
i = i + 1
Loop Until IsEmpty(Cells(i, 1))

where For i = 1 to 9 are the row numbers of the email addresses.

 

[DipDip]

Cheers but found a much simpler solution.