Happy New Year
I need to send my excel file through my macro. It seems to do everything that I need it to but won't send. I get the error: "Cannot find path specified" and highlights the line just before the 'Send' line. The file needs to be converted to xlsx, because the receiver will probably not have Macros activated. . When it comes to sending the file, it can't find it.
Any help would be greatly appreciated. This problem has been a thorn in my side for quite a while. Thanks so much
Code
Sub EmailDrFamily()
Dim Msg As Object
Dim Conf As Object
Dim msgBody As String
Dim ConfFields As Variant
Dim wb As Workbook
Dim FilePath As String
Dim FileName As String
Dim FirstEmail
Dim Usr
Dim Pass
Dim Ser
Dim Nam
Dim Em
Dim Sento
Dim Subj
Call GYFamilyLessApps
If Sheets("Home Sheet").Range("J45").Value = "Yes" Then
Exit Sub
End If
'This tests if user chooses to look at instructions (disables sub)
If Sheets("Home Sheet").Range("J45").Value = "Cancel" Then
Sheets("Home Sheet").Range("A1").Activate
End If
'This tests if user decides not to set Less Secure (gives option to try or quit)
If Sheets("Home Sheet").Range("J45").Value = "N0" Then
End If
'This tetss if user does not need instructions (continues with e-mail procedure)
Range("J45").FormulaR1C1 = " "
Result = MsgBox("Shall we continue to send message?" & vbNewLine & vbNewLine & _
"Click Yes to continue with sending." & vbNewLine & "Click No to return to home page." _
& vbNewLine & vbNewLine & "YES = CONTINUE" & vbNewLine & "NO = STOP! GO TO HOME", _
vbYesNo + vbQuestion, "SEND E-MAIL")
If Result = vbYes Then
Else: Sheets("Home Sheet").Activate
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please just click on any folder and click OK below, to activate the email"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder. Please try again." & vbNewLine & "The folder is just used as a temporary holding area so the file can be sent"
Exit Sub
Else
FilePath = .SelectedItems(1) & "\"
End If
End With
FileName = wb.Name
'wb.SaveCopyAs FilePath & FileName
wb.SaveAs FilePath & FileName & Format(Date, "ddmmyyyy") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
DisplayAlerts = False
''/// get the path and name of the saved copy to attach
FileName = Workbooks(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5) & ".xlsx").FullName
Set Msg = CreateObject("CDO.Message")
Set Conf = CreateObject("CDO.Configuration")
Sheets("Default Sheet").Select
'Below sets email username, password, address, parients name & subject variables
Usr = Range("B43").Value
Pass = Range("B44").Value
Em = Range("B45")
Nam = Range("B39")
Sheets("Home Sheet").Select
Subj = Range("C34")
'The next 3 "IF" blocks determine which email server you are using from your default sheet
If wb.Sheets("Default Sheet").Range("E43").Value = "gmail" Then
Sheets("Home Sheet").Range("A42:C42").Select
With Selection
.ClearContents
.Interior.ColorIndex = vb0
'Clearing "Sent & Date & Time" as the patient is sending a new email
End With
Sheets("Default Sheet").Select
Conf.Load -1
'CDO Source Defaults
Set ConfFields = Conf.Fields
With ConfFields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'Enter the username and password of your email account below
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Usr
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass
'Edit the SMTP server below e.g. smtp.gmail.com or smtp.mail.yahoo.co.uk
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "Smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Update
End With
End If
If wb.Sheets("Default Sheet").Range("E43").Value = "yahoo" Then
Sheets("Home Sheet").Range("A42:C42").Select
With Selection
.ClearContents
.Interior.ColorIndex = vb0
'Clearing "Sent & Date & Time" as the patient is sending a new email
End With
Sheets("Default Sheet").Select
Conf.Load -1
'CDO Source Defaults
Set ConfFields = Conf.Fields
With ConfFields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'Enter the username and password of your email account below
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Usr
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass
'Edit the SMTP server below e.g. smtp.gmail.com or smtp.mail.yahoo.co.uk
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
End If
If wb.Sheets("Default Sheet").Range("E43").Value = "outlook" Then
Sheets("Home Sheet").Range("A42:C42").Select
With Selection
.ClearContents
.Interior.ColorIndex = vb0
'Clearing "Sent & Date & Time" as the patient is sending a new email
End With
Sheets("Default Sheet").Select
Conf.Load -1
'CDO Source Defaults
Set ConfFields = Conf.Fields
With ConfFields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
'Enter the username and password of your email account below
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Usr
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass
'Edit the SMTP server below e.g. smtp.gmail.com or smtp.mail.yahoo.co.uk
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp-mail.outlook.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587
.Update
End With
End If
FirstEmail = Sheets("Default Sheet").Range("B46").Value
'This variable is set to Dr Family
Sento = Sheets("Default Sheet").Range("A46")
'This variable is set to place name of recipient in MsgBody
msgBody = "Hi" & Sento & vbNewLine & vbNewLine & _
"Please find the Excel workbook attached."
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.ActiveWorkbook.Worksheets("Default Sheet").Select
Range("B38,B44").ClearContents
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Default Sheet" And xWs.Name <> "Exercise Chart" _
And xWs.Name <> "BP Chart" And xWs.Name <> "INR Chart" _
And xWs.Name <> "Weight Chart" And xWs.Name <> "Glucose Chart" _
And xWs.Name <> "Meals Chart" And xWs.Name <> "Exercise Data" _
And xWs.Name <> "BP Data" And xWs.Name <> "INR Data" _
And xWs.Name <> "Weight Data" And xWs.Name <> "Glucose Data" _
And xWs.Name <> "Meals Data" And xWs.Name <> "Sign In" _
And xWs.Name <> "LOG ENTRIES" And xWs.Name <> "Disclaimer" Then
xWs.Delete
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.ActiveWorkbook.Worksheets("Sign In").Select
With Msg
Set .Configuration = Conf
'Add the email address to whom to send the email below
.To = FirstEmail
.CC = ""
.BCC = ""
.From = Em
.Subject = Subj
.TextBody = msgBody
.AddAttachment FilePath & FileName
.Send
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Sheets("Home Sheet").Select
Range("C42").Select
With ActiveCell
.FormulaR1C1 = "SENT"
.Font.Bold = True
.Font.Size = 28
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Color = vbBlack
.Interior.ColorIndex = 38
Call Pause1
.Interior.Color = vbYellow
Call Pause1
.Interior.Color = vbGreen
End With
Range("A42").Select
With ActiveCell
.FormulaR1C1 = "=Today()"
.Copy
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Interior.Color = vbGreen
End With
Range("B42").Select
With ActiveCell
.Value = Format(Now(), "HH:MM")
.Interior.Color = vbGreen
End With
Call GYDisallowLessSecureApps
End Sub
Display More