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