Error: Cannot find path specified when sending my attachment with CDO

JimmyB · Jan 8th 2020

Hi Roy From your questions:

Question OnLine 28: The program has the built in feature to send email with the CDO and g-mail requires the user to activate “Allow less secure apps”. I’m giving the user the option to opt out in case they don’t feel safe. Sub: GYFamilyLessApps that I’m calling before this, uses msgbox to determine this... and place value in J45 (Works Perfectly)

Question OnLine 40: This bolsters the previous decision and allows them to either continue to email or opt out (Works Perfectly)

I didn't see anything new except for the questions (above) in the sub that you included in your last post...did I miss something

JimmyB · Jan 8th 2020

Hey Uncle Stringer & Dave. Sorry I didn't get a chance to try your suggestions. It seems reasonable. Will look harder at them when I clear my mind. LOL Working on Roy's recommendations

I need it to open as xlsx, as I don't want the copy to be sent from the user to the physician, with error messages [opping up when they hit the form control buttons. It must be clean. It will be initially sent from me to the user, then altered and sent to their recipients (redacted) for viewing only.

The whole program works great except for this: "Cannot find path specified" and highlights the line just before the 'Send' line. If not trying to delete the selected sheets and change to xlsx it sends great as xlsm.

I've found where it's changed the file but the sub can't find it when time to 'SEND'

arggghhh

JimmyB · Jan 8th 2020

Hi Uncle Stringer

I tried your suggestion. it saved as xlsx as I wanted, but it doesn't send. I get the error: 'Process cannot access the file because it is being used by another process'. It does come up as the xlsx file on my screen...therefore that's likely why I'm getting the error. Need it to not open on my screen somehow?

Jimmy

JimmyB · Jan 8th 2020

Any suggestions will try tomorrow...gotta go for now...Thanks all

JimmyB · Jan 8th 2020

BTW I used your code from #11 thread

JimmyB · Jan 9th 2020

Hey guys. this is the closest that I've ever gotten on this problem. I tried some ideas from Uncle Striker. and have come to this: The file saves as xlsx in the proper location in my folder. It does not alter the original file, The file shuts down as needed. This is great...only problem is, it doesn't 'SEND' the file. I don't want to touch it until I get direction. ALSO: I'm not getting any errors, it just isn't sending the file. Ignore the rem statements. While altering the sub I just changed some of the code that I replaced to rem statements, so as not to lose it if I need to return.

Here's the code:

Thanks Jimmy

Code

Sub EmailDrFamily()

    Dim Msg As Object
    Dim Conf As Object
    Dim msgBody As String
    Dim ConfFields As Variant
    Dim wb As Workbook, sh As Worksheet
    Dim FilePath As String
    Dim FileName As String
    Dim FirstEmail
    Dim AtchFile As String
    Dim Usr
    Dim Pass
    Dim Ser
    Dim Nam
    Dim Em
    Dim Sento
    Dim Subj
    
    
    'THIS BLOCK STARTS THE ALLOW LESS APPS DECISION
    
         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
        
    'THIS IS THE END OF THE ALLOW LWSS SECURE APPS AREA
    
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

        Set wb = ActiveWorkbook
        Set sh = wb.Sheets("Sheet1")
        Application.DisplayAlerts = False
    With sh
        FilePath = wb.Path & "\"
        FileName = Left(wb.Name, Len(wb.Name) - 5)
        AtchFile = FilePath & FileName & "-" & Format(Date, "ddmmyyy") & ".xlsx"
  
  'START OF DELETE SHEETS BLOCK
  
   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
         
    'END OF DELETE SHEETS BLOCK
    
            Application.DisplayAlerts = True
            Application.ScreenUpdating = True
            Application.ActiveWorkbook.Worksheets("Sign In").Select
    
    With ActiveWorkbook
        .SaveAs AtchFile, 51
        .Close
    End With
    
    
    End With
    
   ' 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
        
        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
    
     
    
        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."
              
    MsgBox FileName
    MsgBox AtchFile
   '     With Workbooks("FileName")
    '        .Close
     '   End With
    ' ActiveWorkbook.Close SaveChanges:=True
     
        
    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 AtchFile, 51
        .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

davesexcel · Jan 9th 2020

You are starting out as a .xlsm workbook, then saving that workbook as .xlsx then closing the workbook before the code finishes.

Once you saveas a new name that workbook, you are no longer on it.

This is why UncleString was trying to show you how to create a separate workbook so you still stayed on the original workbook.

Fortunately, your last post has given us enough information that we can create and save a workbook on the fly.

That part of the code is this.

Code

        '----------------Save selected sheets as a new workbook--------------------
        Sheets(Array("Disclaimer Then", "Sign In", "Glucose Data", "INR Data", _
                     "Exercise Data", "Glucose Chart", "INR Chart", "Exercise Chart", "LOG ENTRIES", _
                     "Meals Data", "Weight Data", "BP Data", "Meals Chart", "Weight Chart", "BP Chart", _
                     "Default Sheet")).Copy
        ActiveWorkbook.SaveAs AtchFile
        ActiveWorkbook.Close
        '----------end of save selected sheets as new workbook---------------

The correct file does show up at the addattchment line

For me, I can't get past the ".send", it has nothing to do with the attachment but has something to do with the gmail settings possible an app password, not sure though.

Here is the full code now, I had to comment out the call macro lines

Code

Sub EmailDrFamily()

    Dim Msg As Object
    Dim Conf As Object
    Dim msgBody As String
    Dim ConfFields As Variant
    Dim wb As Workbook, sh As Worksheet
    Dim FilePath As String
    Dim FileName As String
    Dim FirstEmail
    Dim AtchFile As String
    Dim Usr
    Dim Pass
    Dim Ser
    Dim Nam
    Dim Em
    Dim Sento
    Dim Subj


    'THIS BLOCK STARTS THE ALLOW LESS APPS DECISION

    '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

    'THIS IS THE END OF THE ALLOW LWSS SECURE APPS AREA


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ActiveWorkbook
    Set sh = wb.Sheets("Sheet1")
    Application.DisplayAlerts = False
    With sh
        FilePath = wb.Path & "\"
        FileName = Left(wb.Name, Len(wb.Name) - 5)
        AtchFile = FilePath & FileName & "-" & Format(Date, "ddmmyyy") & ".xlsx"

        '----------------Save selected sheets as a new workbook--------------------
        Sheets(Array("Disclaimer Then", "Sign In", "Glucose Data", "INR Data", _
                     "Exercise Data", "Glucose Chart", "INR Chart", "Exercise Chart", "LOG ENTRIES", _
                     "Meals Data", "Weight Data", "BP Data", "Meals Chart", "Weight Chart", "BP Chart", _
                     "Default Sheet")).Copy
        ActiveWorkbook.SaveAs AtchFile
        ActiveWorkbook.Close
        '----------end of save selected sheets as new workbook---------------

        'START OF DELETE SHEETS BLOCK

        Dim xWs As Worksheet
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False

        Application.ActiveWorkbook.Worksheets("Default Sheet").Select
        Range("B38,B44").ClearContents


        'END OF DELETE SHEETS BLOCK

        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Application.ActiveWorkbook.Worksheets("Sign In").Select



    End With

    ' 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

    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



    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."

    MsgBox FileName
    MsgBox AtchFile
    ' With Workbooks("FileName")
    ' .Close
    ' End With
    ' ActiveWorkbook.Close SaveChanges:=True


    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 AtchFile
        .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

davesexcel · Jan 9th 2020

I forgot to add the file format to the saveas line.

JimmyB · Jan 9th 2020

Hi Dave. I completed the saveas line as AtchFile, 51

I copied the code you provided into a copy of my program. (Is there a way to copy this without line numbers? When I copied it looked as though there was no line numbers, but when I pasted, somehow it included the line numbers, causing syntax error on every line. I went line for line and deleted the numbers LOL)

...Anyway

In the amended sub, you made a bit of an error on one of the sheets that you copied into the Array. You put "Disclaimer Then"...should be just "Disclaimer". You had mentioned that you had problem with the 'send' and I hoped that this was the problem, but no luck.

You mentioned that there may be a problem with the email code, but the email works perfectly when sending the full file...no issues at all.

Also there is personal content in the 'Default" sheet, such as email password etc., that must also be cleared before creating the new workbook (Lines 73 & 74) of my code That I sent in the #26 post above.

By creating the new workbook with no email password, should not be an issue, as we are using the original file to 'send'

I inserted the deletion just above the... Sheets(Array... line

Code

Application.ActiveWorkbook.Worksheets("Default Sheet").Select
 Range("B38,B44").ClearContents

When I run the program I get an error "Subscript out of range" on the new code: Sheets(Array.....

I really appreciate your help.

Thanks Jimmy

davesexcel · Jan 10th 2020

I moved the save new workbook down the code to after you have edited the sheets.

Cleaned up the code a bit

All the sheet names in the code need to match the sheet names on the sheet or you will get subscript out of range

Code

Sub EmailDrFamily()

    Dim Msg As Object
    Dim Conf As Object
    Dim msgBody As String
    Dim ConfFields As Variant
    Dim wb As Workbook, sh As Worksheet
    Dim FilePath As String
    Dim FileName As String
    Dim FirstEmail
    Dim AtchFile As String
    Dim Usr
    Dim Pass
    Dim Ser
    Dim Nam
    Dim Em
    Dim Sento
    Dim Subj
    Set wb = ActiveWorkbook
    Set sh = wb.Sheets("Home Sheet")


    'THIS BLOCK STARTS THE ALLOW LESS APPS DECISION

    'Call GYFamilyLessApps
    With sh
        If .Range("J45").Value = "Yes" Then
            Exit Sub
        End If
        'This tests if user chooses to look at instructions (disables sub)
        If .Range("J45").Value = "Cancel" Then
        End If
        'This tests if user decides not to set Less Secure (gives option to try or quit)
        If .Range("J45").Value = "N0" Then
        End If
        'This tetss if user does not need instructions (continues with e-mail procedure)
        .Range("J45").FormulaR1C1 = " "
    End With

    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: sh.Activate
        Exit Sub
    End If

    'THIS IS THE END OF THE ALLOW LWSS SECURE APPS AREA


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Application.DisplayAlerts = False
    FilePath = wb.Path & "\"
    FileName = Left(wb.Name, Len(wb.Name) - 5)
    AtchFile = FilePath & FileName & "-" & Format(Date, "ddmmyyy") & ".xlsx"

    Worksheets("Default Sheet").Range("B38,B44").ClearContents


    Set Msg = CreateObject("CDO.Message")
    Set Conf = CreateObject("CDO.Configuration")

    'Below sets email username, password, address, parients name & subject variables
    With Sheets("Default Sheet")
        Usr = .Range("B43").Value
        Pass = .Range("B44").Value
        Em = .Range("B45")
        Nam = .Range("B39")
    End With

    Subj = sh.Range("C34").Value

    '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

        With sh.Range("A42:C42")
            .ClearContents
            .Interior.ColorIndex = vb0
            'Clearing "Sent & Date & Time" as the patient is sending a new email
        End With

        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

        With sh.Range("A42:C42")
            .ClearContents
            .Interior.ColorIndex = vb0
            'Clearing "Sent & Date & Time" as the patient is sending a new email
        End With


        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

    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."

    '----------------Save selected sheets as a new workbook--------------------
    Sheets(Array("Disclaimer", "Sign In", "Glucose Data", "INR Data", _
                 "Exercise Data", "Glucose Chart", "INR Chart", "Exercise Chart", "LOG ENTRIES", _
                 "Meals Data", "Weight Data", "BP Data", "Meals Chart", "Weight Chart", "BP Chart", _
                 "Default Sheet")).Copy
    ActiveWorkbook.SaveAs AtchFile, 51
    ActiveWorkbook.Close
    '----------end of save selected sheets as new workbook---------------

    MsgBox FileName
    MsgBox AtchFile

    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 AtchFile
        '.Send
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

    With sh
        With .Range("C42")
            .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

        With .Range("A42")
            .Value = Date
            .Interior.Color = vbGreen
        End With

        With .Range("B42")
            .Value = Format(Now(), "HH:MM")
            .Interior.Color = vbGreen
        End With
    End With

    'Call GYDisallowLessSecureApps
End Sub

Display More

If you do copy the code and it pastes with the line numbers, experiment with pasting it on a sheet and using text to columns to remove that first space.

Oh, I commented out the .send so I can get to the end of the code.

davesexcel · Jan 10th 2020

Not sure if you are using the copy icon to copy the code

-

JimmyB · Jan 10th 2020

Hi Dave.

I did find one of my sheet names was incorrect. "Meal Chart" should have been "Meals Charts" (Plural). argghhh.

Line 63 of your code is where the password is cleared. I moved it to just before the rest of the delete happens...before line 142

I even tried to remove this line altogether to see if it may have been the issue and still got the below results

I update my code with yours. I got error on (set sh as wb.sheets... Object does not support method so I removed the wb and that worked. so set as:

sh = Sheets("Home Sheet")...seems good.

I placed a few msgbox's after the variables: User, Pass & Em. the first two show as .844444444 & the Em shows blank. I made sure that the ranges are correct. The code runs right to the 'Send' statement...error: "At least one of the from or sender fields is required and neither was found"

The original file has the password deleted from "Default Sheet". Can't see why. (Probably the problem) The new file is saved properly as necessary) in my folder but just not sent.

Thanks Jimmy

UncleStringer · Jan 13th 2020

Just a quick observation,

You can delete the cells from the copied workbook.

After sheets.copy that new workbook is the active workbook, so

for example:

activeworkbook.sheets(sheetName).range("A1:B1").clearcontents

You can do all this before activeworkbook.saveas

JimmyB · Jan 13th 2020

HEY Dave...Thanks...I didn't know about the 'Copy Icon' very very helpful info.haha

Actually I re-copied your sub again using the 'Copy Icon' and must have missed something when I originally did it manually. The copied file in in my folder . Only problem now is that I'm getting a transport error when it tries to send, because the email password is deleted prematurely in the original file. But we're much closer...almost got it

I moved the deleted line to after the saveas and it sent but not with deleted content. Tonight I'll just ad a resave line of code after the cell deletion so it saves before it sends.

JimmyB · Jan 14th 2020

HEY DAVESEXCEL...IT WORKED!

perfectly. You are a genius. I don't know how you guys do this with the limited information you get from us (me especially I guess).

Thanks to all of you that contributed Dave, Uncle S, RoyUK & Carim (originally)

Error: Cannot find path specified when sending my attachment with CDO

Participate now!

Share

Tags