Posts by JimmyB

JimmyB · Dec 23rd 2019

Hi.

I'm having issues with deleting a line of code in my ThisWorkbook Workbook open event. it worked at one time then suddenly it stopped working. It doesn't give me an error when I run the program, but it just doesn't delete the line of code, like it should. When I open the sub and step through it I get the error code "Can't enter break mode at this time." I've checked to make sure the line number matched & I want to delete only that line.
Your help will be greatly appreciated
If I step through the file and get the error then hit continue or end it deletes the code like it should... but does not go to "End With"
I tried to input the line "On Error Resume Next" to try to override the error...well that line of code doesn't work on anything that I've tried.

i've cross-posted on 2 forums. Plenty of traffic but no suggestions

https://www.excelforum.com/exc…his-time.html#post5248130

https://www.excelguru.ca/forum…r-break-mode-at-this-time

If I'm doing anything that doesn't fit in with Ozgrid forum, please explain to me. The moderators are great and I want to get things right.

Thanks a ton

Here is the code:

Code

Sub DeleteCodeLines()

Dim wb As Workbook
   
        Set wb = ThisWorkbook
    With wb.VBProject.VBComponents("ThisWorkbook").CodeModule
        .DeleteLines 42, 1
    End With
   
End Sub

Thanks

Display More

JimmyB · Dec 16th 2019

Yeah...still the same. anyway the problem has been solved with logits post. Sorry I didn't mean to create a peeing contest. don't want to cause any more grief...thanks for your help. I know you are acting with best intentions...signing off for now

Thanks

JimmyB

JimmyB · Dec 16th 2019

Well Roy, I'm not trying to be impossible but the link that you sent me locked up my computer and i needed to reset it in task manager (I just tried it again) with the same results. The url that you just sent me, comes up with "Page not found".

The reason that I started a new thread is because you threatened to delete my posts (Post #6) and I still needed help on the issue. (Post #5)

Just sayin'

Have a great day

Sorry we can't seem to get on well

JimmyB · Dec 15th 2019

WAHOO...GREAT JOB Logit...works perfectly

Thanks so much

JimmyB

JimmyB · Dec 15th 2019

The link is PASSWORD-FORM-7.xlsm. Tried on 2 different computers and locked up both...just dings when clicked anywhere...had to disable it with task manager

This link opens up the page that I've attached which mentions "if I need help with the project pleas contact sales&excel-it.com" for a quotation"

I thought that it was driven by you... Sorry my mistake.

Anyway I really need my simple question answered that I posted in the thread post to 'Logit'. You advised that you're deleting my posts, so should I just start a new thread?

Lot of confusion here today...sheesh

Maybe you can help me?

I need to delete the line "call inputbox2" on my workbook event. I found the sub to delete that line of code but I get error "Object Required" on the line...Can you please help? When it says object required I draw a blank...(my Nemesis

Thanks so much...Sorry for the confusion. I just don't want to offend anyone

Code

Sub DeleteCodeLines()
ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule.DeleteLines 42,1
End Sub

THANKS Roy

JimmyB

JimmyB · Dec 15th 2019

Hey Roy. I forgot to mention that I'm a senior on a govt pension and can't afford your recommendation to hire someone to help with the userform. I guess that is why I check on the forums for help...LOL. (just trying to keep the mind active with these projects). You said you want to delete my posts. Why is that? I really need a bit more help on this issue.

btw. The link you sent me locked up my computer. I had to go to task manager to dump it. Anyway please let me know if I've done something to offend you. That was not my intent whatsoever

Thanks JimmyB

JimmyB · Dec 13th 2019

On second thought...I can't delete the sub while I'm standing in it. Right?

I'm calling the sub Inputbox2 in my workbook open event, and actually need to delete it, directly after it has run, so It doesn't show up for a second go-round

If that makes sense

HELP please with the syntax

Thanks Jimmy

JimmyB · Dec 13th 2019

Hi. I have a program where I have an inputbox in the 'Workbook event', that prompts me to assign a password to access the file, without going through the tedium of opening the file, going through the disclaimer sheet and various hoops to get to the password area. That part works fine.

Now what I need, is to delete this inputbox as soon as the password is inserted, otherwise anyone will get the inputbox on the "Sign In" sheet, when they open the file...then change the password to whatever.

Here is what I have for the code. Just one line with syntax problem...I think

Thanks so much

Jimmy

Code

Sub Inputbox2()

Dim inbx As String

        inbx = InputBox("Program the New Password" & vbNewLine & vbNewLine & "DEVELOPER SECTION", _
            "Assign Password BOX", "Type Here", 1600, 6000)
            'This is for the programmer to insert the password for the program
       
        Sheets("Default Sheet").Activate
        Range("B38").Value = inbx
    If Range("B38").Value = inbx Then
   
'Something wrong with the syntax in the line below
        Sheets("Sign In").ibnx.Delete
    End If
End Sub

Display More

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

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

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 21st 2019

Very much appreciate it

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.

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

JimmyB · Nov 19th 2019

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

Thanks Jimmy

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

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

JimmyB · Nov 11th 2019

Hi Roy.
I've been digging deeper and giving a lot of thought to your recommendation. I have to agree that it would be much better, for the user to create a modified sheet before emailing it out. Now in saying that I have no idea of the path that the patient will use, I need to create code that acknowledges and saves the path chosen by the patient. I've created the code below:
Unfortunately it is not quite working. It creates the new workbook with the name "Guest" and in xlsx format, like I want, but I get error messages that advises type mismatch
Your usual great help will be appreciated
Thanks Jimmy

Code

Sub SaveAsGuestNonMacro()
       
Dim wb As Workbook


        Set wb = ActiveWorkbook
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please just click on any folder"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not make a selection" & vbNewLine & "Please try again" _
            & vbNewLine & "The Folder is just used as a temporary holding area"
        Else
            FilePath = .SelectedItems(1) & "\"
        End If
    End With
    
            FileName = wb.Name
            wb.SaveAs FileName:=FilePath \ "Guest.xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
            
End Sub

Display More

JimmyB · Nov 10th 2019

Hi Roy
Sorry but that option is not what I'm looking for . I'm making this app as simple as possible for seniors that may not be computer savvy, I already am deleting certain cells with data and certain worksheets, by way of the Workbook Open event. That isn't the problem. I just need the syntax to either delete or disable all of the form control buttons, as they are not necessary (for the end user), and cause errors when the person hits them.
Any help will be appreciated
Jimmy

Posts by JimmyB

Can't enter break mode at this time

+how to delete an inputbox

+how to delete an inputbox

+how to delete an inputbox

+how to delete an inputbox

+how to delete an inputbox

+how to delete an inputbox

+how to delete an inputbox

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

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

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

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

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

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

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

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

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

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

Need Workbook to be Read Only and all control form buttons to be disabled or deleted

Need Workbook to be Read Only and all control form buttons to be disabled or deleted