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