want to convert Macro enabled file to xlsx in my CDO sub

JimmyB · Nov 13th 2019

Hi

My CDO works fine to send my file macro enabled, but I want to convert my file to disabled macros as it is being prepared to send with the CDO. Below is the code that I used:

I need to make this process for the user as simple as possible as my target audience that will be sending the file will be seniors sending data to their doctor. Therefore some information must be automatically deleted when the patient activates the SEND button. The program has about 25 pages each interactive and hard to explain.

I'm getting errors in the SAVEAS area. I've tried different variations but can't figure out the syntax

Any help will be appreciated.

Thanks JimmyB

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
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Call DeleteSheets
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.xlsx, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
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."
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
End Sub

Display More

royUK · Nov 14th 2019

Code

wb.SaveCopyAs FilePath & FileName.xlsx, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False

The line above taken from your code saves the workbook as .xlsx so code will be removed

royUK · Nov 14th 2019

You could improve your code by removing the selecting and references to the ActiveCell.

JimmyB · Nov 14th 2019

Hi Roy Sorry for the late reply...crazy busy lately

I tried what you suggested. When I tried to run it, I got and error: "Invalid qualifier" on the variable FileName. Before I put the extension on it, ".xlsx" the file worked a it did previously, and sent it macro enabled.

royUK · Nov 15th 2019

Your code is saving a copy as .xlsx, but not sending that copy. It is still sending the master workbook.

royUK · Nov 15th 2019

I've worked through your code.

You cannot use SaveCopyAs and specify a different file format so I've changed to use saveas but added the date to filename. This workbook is then used as the attachment.

I've tried to remove unnecessary selecting and feel the code could be shortened more but I haven't time at the moment.

This code should send a macro free workbook, remember I haven't tested it because I do not have the full workbook so use a backup of your workbook.

Code

Option Explicit
Sub EmailDrFamily()
Dim wb As Workbook
Dim Msg As Object, Conf As Object
Dim msgBody As String, FilePath As String, FileName As String
Dim Usr As String, Pass As String, Ser As String, Nam As String, Em As String, Sento As String, Subj As String
Dim ConfFields As Variant
Dim FirstEmail
With Application
.ScreenUpdating = False
.EnableEvents = False
Set wb = ActiveWorkbook
Call DeleteSheets
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
.DisplayAlerts = False
wb.SaveAs FilePath & FileName & Format(Date, "ddmmyyyy") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
.DisplayAlerts = True
''/// 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")
With Sheets("Default Sheet")
'Below sets email username, password, address, parients name & subject variables
Usr = .Range("B43").Value
Pass = .Range("B44").Value
Em = .Range("B45")
Nam = .Range("B39")
End With
Subj = Sheets("Home Sheet").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
With Sheets("Home Sheet").Range("A42:C42")
.ClearContents
.Interior.ColorIndex = vbGreen
'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
With Sheets("Home Sheet").Range("A42:C42")
.ClearContents
.Interior.ColorIndex = vbGreen
'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
With Sheets("Home Sheet").Range("A42:C42")
.ClearContents
.Interior.ColorIndex = vbGreen
'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."
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 FileName
.Send
End With
With Sheets("Home Sheet").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 Sheets("Home Sheet").Range("A42")
.FormulaR1C1 = Format(Date, "long date")
.Interior.Color = vbGreen
End With
With Sheets("Home Sheet").Range("B42")
.Value = Format(Time, "HH:MM")
.Interior.Color = vbGreen
End With
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Display More

**alansidman** · Nov 15th 2019

crossposted: https://www.excelforum.com/exc…sx-in-cdo-code-block.html

Cross-posting Without Telling Us

Your post does not comply with our Forum RULES. Do not cross-post your question on multiple forums without telling us about your threads on other forums.

Post a link to any other forums where you have asked the same question.

Cross-posting is when you post the same question in other forums on the web. The last thing you want to do is waste people's time working on an issue you have already resolved elsewhere. We prefer that you not cross-post at all, but if you do (and it's unlikely to go unnoticed), you MUST provide a link (copy the url from the address bar in your browser) to the cross-post.

Go to https://www.excelguru.ca/content.php?184 to understand why we ask you to do this.

I have added the crosspost reference for you today. Please comply with this and all our rules in the future

JimmyB · Nov 19th 2019

Sorry Allan,

actually I originally posted in this forum and had no replies in the first couple of days earlier on, so I posted in The Excel F?rum. There, I'd advised them that it was cross posted, and didn't succeed with figuring out my problem, with the help that they provided, so I came back here to check if anyone responded and Roy had. In the confusion I forgot to advise Roy that I had cross posted. Sorry JimmyB

JimmyB · Nov 19th 2019

Roy I just got back in town and will try out you recommendation Tuesday night

Thanks Jimmy

royUK · Nov 19th 2019

No problem

Have you posted a follow on to this question because I've seen something similar?

JimmyB · Nov 20th 2019

Well. I've been trying for a few hours to make the code work that you provided to no avail. I understand that it is hard for you to go at this, kind of blindly, but the program is about 25 or so worksheets long and interactive amongst each other, so I'm giving you information the best that I can, without creating too much fog. I did although, combine a few lines from yours to mine and have made some progress. Almost there but still a minor problem. The code now converts the file to xlsx. and deletes the sheets that I need deleted, but stops at the last second before sending. I get the error code: "Filename, Directory Name or volume label Syntax is Incorrect". This pops up just at the bottom, highlighting ".Add Attachment FilePath & FileName". I know that you can help improve to streamline the code but I really need it to work (first) LOL. Below is the adjusted code:

Your usual patience & help will be greatly appreciated

Thanks so much Jimmy

(Hitting the sack. Will check back tomorrow)

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
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
DisplayAlerts = False
wb.SaveAs FilePath & FileName & Format(Date, "ddmmyyyy") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
DisplayAlerts = True
''/// 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."
Call DeleteSheets
Debug.Print FileName
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
End Sub

Display More

royUK · Nov 20th 2019

When it fails hover the cursor over FileName and FilePath to see what the value is, check that it is correct. I don't think it is the Volume Label

JimmyB · Nov 20th 2019

Hi Roy. When I hover over the FileName & FilePath, they are both identified as = ""

For whatever reason it isn't finding the files that it has created.

royUK · Nov 21st 2019

I'll work through that part of the code as soon as I can.

JimmyB · Nov 21st 2019

Very much appreciate it

JimmyB · Nov 27th 2019

Hi Roy. Hope you aren't too swamped. I'm so close to getting my program right. One problem still haunting me and I need some help. When I run the program I get the error (line just before the SEND. error= The process cannot access the file because it is being used by another process

It is converted to xlsx as it should be and all else seems good except for this. Here's the code:

Any help will be greatly appreciated

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
Dim FilePath As String
Dim FileName As String
Dim FirstEmail
Dim Usr
Dim Pass
Dim Ser
Dim Nam
Dim Em
Dim Sento
Dim Subj
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
DisplayAlerts = False
wb.SaveAs FilePath & FileName & Format(Date, "ddmmyyyy") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
DisplayAlerts = False
'Get the pathand 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."
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
Call DeleteSheets
Sheets("Disclaimer").Select
.AddAttachment FileName
Sheets("Disclaimer").Select
.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
End Sub

Display More

JimmyB · Nov 29th 2019

Hi Roy

It's been 8 days since I last heard from you. If you read my last post, you'll see that we're so very close to solving my problem. I feel like we're one line away from ending this thing. I really need to finish this aspect of the program, before i go on much further. I just can't seem to figure it out. You've worked on this extensively and know what I'm after here. If you don't have time to look at this, please just let me know with a quick reply. It'll be like reinventing the wheel but I will need to cross-post this on a different forum...if you or no one else in this forum can help me.

Thanks JimmyB

royUK · Nov 29th 2019

I won't have time to look at this until the weekend

JimmyB · Dec 3rd 2019

Ok Thanks Roy. I'm really having a hard time with this. There are sheets stated for deletion before sending. Instead of using the 'Call' feature I put the lines in the actual program. Here is the code as it stands. right now I'm getting a subscript error and the 'debug' text doesn't show as an option, so I can't say for sure where that error is. GRRRR

Thanks again for your help.

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
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
DisplayAlerts = False
'changes the file from xlsm to xlsx for when the users doctor gets the file
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
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'this deletes certain information that the user does not want to share
Application.ActiveWorkbook.Worksheets("Default Sheet").Select
Range("B38,B44").ClearContents
'the following block saves the following sheets but deletes the rest in the file
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
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
'I can't get the "Yahoo" or "Outlook" to work...but I did get Gmail to work
'so that is the only mail provider that I'm offering until I figure that out (not too important at this time)
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."
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
Sheets("Disclaimer").Select
.AddAttachment 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
End Sub

Display More

Share