MWhiteDesigns
Well-known Member
- Joined
- Nov 17, 2010
- Messages
- 646
- Office Version
- 2016
- Platform
- Windows
Good Morning,
I'm back again! Previously you guys helped create a sheet for that has a userform, inputs information in a sheet, and sends it to a specified email address upon clicking submit. This works great. However I was wondering if it were possible to have the option to send it to 1 of 2 specified email addresses depending on what option is chosen on the userform. Below is the script that sends my file in an email and the second portion is the script that writes the information from the userform to the sheet. Please advise
I'm back again! Previously you guys helped create a sheet for that has a userform, inputs information in a sheet, and sends it to a specified email address upon clicking submit. This works great. However I was wondering if it were possible to have the option to send it to 1 of 2 specified email addresses depending on what option is chosen on the userform. Below is the script that sends my file in an email and the second portion is the script that writes the information from the userform to the sheet. Please advise
Code:
Sub Mail_ActiveSheet()
'Working in 2000-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Attrition for " & Range("C5").Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "user@user.com"
.CC = ""
.BCC = ""
.Subject = "Attrition for " & Range("C5").Value
.Body = ""
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Attrition form has been completed and submitted to Mark L. White.", , "Submitted"
Application.DisplayAlerts = False
Application.Quit
End Sub
Code:
Private Sub CancelCommand_Click()
Unload Me
End Sub
Private Sub ExitCommand_Click()
Application.DisplayAlerts = False
Application.Quit
End Sub
Private Sub CubeTextBox_Change()
End Sub
Private Sub Frame4_Click()
End Sub
Private Sub Label24_Click()
End Sub
Private Sub SubmitCommand_Click()
Dim irow As Long
Dim ws As Worksheet
Set ws = Sheets("HVS Attrition")
With ws
Sheets("HVS Attrition").Unprotect "lcbp41hd"
If NameTextBox.Value = "" Then
MsgBox "Name cannot be blank.", , "Name error"
Exit Sub
End If
If EIDTextBox.Value = "" Then
MsgBox "EID cannot be blank.", , "EID error"
Exit Sub
End If
If DepartmentComboBox.Value = "Please Choose..." Then
MsgBox "Department must be selected.", , "Department selection error"
Exit Sub
End If
If CubeTextBox.Value = "" Then
MsgBox "Cube Number cannot be blank", , "Cube # error"
Exit Sub
End If
If EffectiveDateTextBox.Value = "" Then
MsgBox "Effective Date cannot be blank.", , "Effective Date error"
Exit Sub
End If
If ReasonComboBox.Value = "Please Choose..." Then
MsgBox "Reason for Attrition must be selected.", , "Reason error"
Exit Sub
End If
If ReportedByTextBox.Value = "" Then
MsgBox "Please specify person reporting Attrition", , "Report By error"
Exit Sub
End If
.Cells(5, 3) = NameTextBox.Value
.Cells(9, 3) = EIDTextBox.Value
.Cells(13, 3) = AVAYATextBox.Value
.Cells(19, 3) = CubeTextBox.Value
.Cells(17, 3) = DepartmentComboBox.Value
If Me.RehireableYesOptionButton.Value = True Then
.Cells(19, 9) = "Yes"
End If
If Me.RehireableNoOptionButton.Value = True Then
.Cells(19, 9) = "No"
End If
.Cells(21, 3) = EffectiveDateTextBox.Value
.Cells(23, 3) = ReasonComboBox.Value
.Cells(26, 3) = ReportedByTextBox.Value
.Cells(22, 5).Value = NotesTextBox.Value
If Me.HRYesOptionButton.Value = True Then
.Cells(29, 3) = "Yes"
End If
If Me.HRNoOptionButton.Value = True Then
.Cells(29, 3) = "No"
End If
'Schedule check and inputs
If SundayCheckBox.Value = False Then
If SundayStartTextBox.Value = "" Then
If SundayEndTextBox.Value = "" Then
If MondayCheckBox.Value = False Then
If MondayStartTextBox.Value = "" Then
If MondayEndTextBox.Value = "" Then
If TuesdayCheckBox.Value = False Then
If TuesdayStartTextBox.Value = "" Then
If TuesdayEndTextBox.Value = "" Then
If WednesdayCheckBox.Value = False Then
If WednesdayStartTextBox.Value = "" Then
If WednesdayEndTextBox.Value = "" Then
If ThursdayCheckBox.Value = False Then
If ThursdayStartTextBox.Value = "" Then
If ThursdayEndTextBox.Value = "" Then
If FridayCheckBox.Value = False Then
If FridayStartTextBox.Value = "" Then
If FridayEndTextBox.Value = "" Then
If SaturdayCheckBox.Value = False Then
If SaturdayStartTextBox.Value = "" Then
If SaturdayEndTextBox.Value = "" Then
MsgBox "Please include Associate Schedule"
Exit Sub
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
If RehireableYesOptionButton.Value = False Then
If RehireableNoOptionButton.Value = False Then
MsgBox "Must Specify if associate is re-hireable", , "Re-hireable Error"
Exit Sub
End If
End If
If HRYesOptionButton.Value = False Then
If HRNoOptionButton.Value = False Then
MsgBox "Must Specify if attrition has been completed in HR for managers", , "HR Error"
Exit Sub
End If
End If
If NotesTextBox.Value = "Please specify reason for attrition..." Then
MsgBox "Reason for Attrition must be included", , "Reason Error"
Exit Sub
End If
If Me.SundayCheckBox.Value = True Then
.Cells(5, 7) = "X"
End If
If Me.MondayCheckBox.Value = True Then
.Cells(7, 7) = "X"
End If
If Me.TuesdayCheckBox.Value = True Then
.Cells(9, 7) = "X"
End If
If Me.WednesdayCheckBox.Value = True Then
.Cells(11, 7) = "X"
End If
If Me.ThursdayCheckBox.Value = True Then
.Cells(13, 7) = "X"
End If
If Me.FridayCheckBox.Value = True Then
.Cells(15, 7) = "X"
End If
If Me.SaturdayCheckBox.Value = True Then
.Cells(17, 7) = "X"
End If
.Cells(5, 11).Value = SundayStartTextBox.Value
.Cells(5, 14).Value = SundayEndTextBox.Value
.Cells(7, 11).Value = MondayStartTextBox.Value
.Cells(7, 14).Value = MondayEndTextBox.Value
.Cells(9, 11).Value = TuesdayStartTextBox.Value
.Cells(9, 14).Value = TuesdayEndTextBox.Value
.Cells(11, 11).Value = WednesdayStartTextBox.Value
.Cells(11, 14).Value = WednesdayEndTextBox.Value
.Cells(13, 11).Value = ThursdayStartTextBox.Value
.Cells(13, 14).Value = ThursdayEndTextBox.Value
.Cells(15, 11).Value = FridayStartTextBox.Value
.Cells(15, 14).Value = FridayEndTextBox.Value
.Cells(17, 11).Value = SaturdayStartTextBox.Value
.Cells(17, 14).Value = SaturdayEndTextBox.Value
Sheets("HVS Attrition").Protect "lcbp41hd"
End With
Call Mail_ActiveSheet
Application.Quit
End Sub