Hi John,
Thanks for your reply. Actually my boss has developed this and asked me to solve the issue.
Full code for your reference:
Complete Code:
Dim UpID As Boolean
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then RunChk1 = True Else RunChk1 = False
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then RunChk2 = True Else RunChk2 = False
End Sub
Private Sub CommandButton10_Click()
Unload Me
Dim objLoop As Object
For Each objLoop In VBA.UserForms
If TypeOf objLoop Is UserForm Then Unload objLoop
Next objLoop
End Sub
Private Sub CommandButton11_Click()
Me.Hide
UserForm2.TextBox4.Value = MCc
UserForm2.TextBox5.Value = MBcc
UserForm2.TextBox2.Value = MSub
UserForm2.TextBox1.Value = MailBod
UserForm2.ListBox1.Clear
On Error Resume Next
If UBound(strPath()) > 0 Then
For i = 0 To UBound(strPath()) - 1
UserForm2.ListBox1.AddItem strPath(i)
Next i
End If
On Error GoTo 0
UserForm2.Show
End Sub
Private Sub CommandButton2_Click()
'If there are changes in recipients then check with user if change is universal
If TextBox2.Value <> MCc Or TextBox3.Value <> MBcc Then
If MsgBox("Recepients (cc/Bcc) have changed. Would you like to apply this change across all mails?", vbYesNo) = vbYes Then
If TextBox2.Value <> MCc Then MCc = TextBox2.Value
If TextBox3.Value <> MBcc Then MBcc = TextBox3.Value
End If
End If
'If there are changes in subject then check with user if change is universal
If TextBox5.Value <> MSub Then
If MsgBox("Subject has changed. Would you like to apply this change across all mails?", vbYesNo) = vbYes Then
MSub = TextBox5.Value
End If
End If
'If there are changes in attachments then check with user if change is universal
For i = 0 To ListBox1.ListCount - 1
On Error Resume Next
If ListBox1.ListCount <> UBound(strPath()) Or ListBox1.List(i) <> strPath(i) Then
If MsgBox("There have been changes made to the attachments. Would you like to apply this change across all mails?", vbYesNo) = vbYes Then
ReDim strPath(ListBox1.ListCount)
For j = 0 To ListBox1.ListCount - 1
strPath(j) = ListBox1.List(j)
Next j
End If
Exit For
End If
On Error GoTo 0
Next i
'First check if any of the fields are blank - checkbox to be ticked if user would like to ignore
If TextBox1.Value = "" And TextBox2.Value = "" And TextBox3.Value = "" Then
MsgBox "No email IDs provided to send email! Please update email IDs and try again!"
Exit Sub
ElseIf CheckBox1.Value = False And TextBox5.Value = "" Then
If MsgBox("Subject is blank! Do you want to proceed?", vbYesNo) = vbNo Then
Exit Sub
Else
CheckBox1.Value = True
If TextBox4.Value = "" Then
If MsgBox("Mail Body is blank! Do you want to proceed?", vbYesNo) = vbNo Then
Exit Sub
End If
End If
End If
ElseIf CheckBox1.Value = False And TextBox4.Value = "" Then
If MsgBox("Mail Body is blank! Do you want to proceed?", vbYesNo) = vbNo Then
Exit Sub
Else
CheckBox1.Value = True
End If
End If
If CheckBox2.Value = False Then
'Then check if email IDs are valid
Dim ChMailID1, ChMailID2, ChSpChr, WrngIDs1, WrngIDs2, WrngIDs3 As String
'Removing all spaces from the email ID list
TextBox1.Value = Replace(TextBox1.Value, " ", "")
TextBox2.Value = Replace(TextBox2.Value, " ", "")
TextBox3.Value = Replace(TextBox3.Value, " ", "")
ChSpChr = "/\;'
#$%^&*()_-+=.,<>?[{]}|`~"
'Checking the To: box
For i = Len(TextBox1.Value) To 1 Step -1
k = 0
For j = 1 To Len(ChSpChr)
k = k + 1
If Mid(TextBox1.Value, i, 1) = Mid(ChSpChr, j, 1) Then
TextBox1.Value = Mid(TextBox1.Value, 1, Len(TextBox1.Value) - 1)
Exit For
End If
Next j
If k = Len(ChSpChr) Then Exit For
Next i
i = 1
j = 1
WrngIDs1 = ""
CheckMailIDs:
On Error Resume Next
ChMailID1 = Mid(TextBox1.Value, i, InStr(i, TextBox1.Value, ";") - i)
'No semicolon found. This is the last email ID
If Err.Number <> 0 Then
On Error GoTo 0
If i = 1 Then
k = Len(TextBox1.Value)
Else
k = Len(TextBox1.Value) - i + 1
End If
ChMailID1 = Mid(TextBox1.Value, i, k)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs1 = "" Then
WrngIDs1 = ChMailID1
Else
WrngIDs1 = WrngIDs1 & ", " & ChMailID1
End If
End If
' Semi colon found. There are more than 1 email IDs to check
Else
i = InStr(i, TextBox1.Value, ";") + 1
j = InStr(i, TextBox1.Value, ";")
' j has the position of the next semi colon. There are more IDs to check after this set
If j > i Then
On Error GoTo 0
ChMailID2 = Mid(TextBox1.Value, i, j - i)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs1 = "" Then
WrngIDs1 = ChMailID1
Else
WrngIDs1 = WrngIDs1 & ", " & ChMailID1
End If
End If
If ValidateEmail(ChMailID2) = False Then
If WrngIDs1 = "" Then
WrngIDs1 = ChMailID2
Else
WrngIDs1 = WrngIDs1 & ", " & ChMailID2
End If
End If
i = j + 1
GoTo CheckMailIDs
' There are no more semi colons. So just the last 2 IDs to check
Else
On Error GoTo 0
ChMailID2 = Mid(TextBox1.Value, i, Len(TextBox1.Value) - i + 1)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs1 = "" Then
WrngIDs1 = ChMailID1
Else
WrngIDs1 = WrngIDs1 & ", " & ChMailID1
End If
End If
If ValidateEmail(ChMailID2) = False Then
If WrngIDs1 = "" Then
WrngIDs1 = ChMailID2
Else
WrngIDs1 = WrngIDs1 & ", " & ChMailID2
End If
End If
End If
End If
'Putting a space after every semi colon
TextBox1.Value = Replace(TextBox1.Value, ";", "; ")
'Checking the CC: box
For i = Len(TextBox2.Value) To 1 Step -1
k = 0
For j = 1 To Len(ChSpChr)
k = k + 1
If Mid(TextBox2.Value, i, 1) = Mid(ChSpChr, j, 1) Then
TextBox2.Value = Mid(TextBox2.Value, 1, Len(TextBox2.Value) - 1)
Exit For
End If
Next j
If k = Len(ChSpChr) Then Exit For
Next i
i = 1
j = 1
WrngIDs2 = ""
CheckMailIDs1:
On Error Resume Next
ChMailID1 = Mid(TextBox2.Value, i, InStr(i, TextBox2.Value, ";") - i)
'No semicolon found. This is the last email ID
If Err.Number <> 0 Then
On Error GoTo 0
If i = 1 Then
k = Len(TextBox2.Value)
Else
k = Len(TextBox2.Value) - i + 1
End If
ChMailID1 = Mid(TextBox2.Value, i, k)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs2 = "" Then
WrngIDs2 = ChMailID1
Else
WrngIDs2 = WrngIDs2 & ", " & ChMailID1
End If
End If
' Semi colon found. There are more than 1 email IDs to check
Else
i = InStr(i, TextBox2.Value, ";") + 1
j = InStr(i, TextBox2.Value, ";")
' j has the position of the next semi colon. There are more IDs to check after this set
If j > i Then
On Error GoTo 0
ChMailID2 = Mid(TextBox2.Value, i, j - i)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs2 = "" Then
WrngIDs2 = ChMailID1
Else
WrngIDs2 = WrngIDs2 & ", " & ChMailID1
End If
End If
If ValidateEmail(ChMailID2) = False Then
If WrngIDs2 = "" Then
WrngIDs2 = ChMailID2
Else
WrngIDs2 = WrngIDs2 & ", " & ChMailID2
End If
End If
i = j + 1
GoTo CheckMailIDs1
' There are no more semi colons. So just the last 2 IDs to check
Else
On Error GoTo 0
ChMailID2 = Mid(TextBox2.Value, i, Len(TextBox2.Value) - i + 1)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs2 = "" Then
WrngIDs2 = ChMailID1
Else
WrngIDs2 = WrngIDs2 & ", " & ChMailID1
End If
End If
If ValidateEmail(ChMailID2) = False Then
If WrngIDs2 = "" Then
WrngIDs2 = ChMailID2
Else
WrngIDs2 = WrngIDs2 & ", " & ChMailID2
End If
End If
End If
End If
'Putting a space after every semi colon
TextBox2.Value = Replace(TextBox2.Value, ";", "; ")
'Checking the BCC: box
For i = Len(TextBox3.Value) To 1 Step -1
k = 0
For j = 1 To Len(ChSpChr)
k = k + 1
If Mid(TextBox3.Value, i, 1) = Mid(ChSpChr, j, 1) Then
TextBox3.Value = Mid(TextBox3.Value, 1, Len(TextBox3.Value) - 1)
Exit For
End If
Next j
If k = Len(ChSpChr) Then Exit For
Next i
i = 1
j = 1
WrngIDs3 = ""
CheckMailIDs2:
On Error Resume Next
ChMailID1 = Mid(TextBox3.Value, i, InStr(i, TextBox3.Value, ";") - i)
'No semicolon found. This is the last email ID
If Err.Number <> 0 Then
On Error GoTo 0
If i = 1 Then
k = Len(TextBox3.Value)
Else
k = Len(TextBox3.Value) - i + 1
End If
ChMailID1 = Mid(TextBox3.Value, i, k)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs3 = "" Then
WrngIDs3 = ChMailID1
Else
WrngIDs3 = WrngIDs3 & ", " & ChMailID1
End If
End If
' Semi colon found. There are more than 1 email IDs to check
Else
i = InStr(i, TextBox3.Value, ";") + 1
j = InStr(i, TextBox3.Value, ";")
' j has the position of the next semi colon. There are more IDs to check after this set
If j > i Then
On Error GoTo 0
ChMailID2 = Mid(TextBox3.Value, i, j - i)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs3 = "" Then
WrngIDs3 = ChMailID1
Else
WrngIDs3 = WrngIDs3 & ", " & ChMailID1
End If
End If
If ValidateEmail(ChMailID2) = False Then
If WrngIDs3 = "" Then
WrngIDs3 = ChMailID2
Else
WrngIDs3 = WrngIDs3 & ", " & ChMailID2
End If
End If
i = j + 1
GoTo CheckMailIDs2
' There are no more semi colons. So just the last 2 IDs to check
Else
On Error GoTo 0
ChMailID2 = Mid(TextBox3.Value, i, Len(TextBox3.Value) - i + 1)
If ValidateEmail(ChMailID1) = False Then
If WrngIDs3 = "" Then
WrngIDs3 = ChMailID1
Else
WrngIDs3 = WrngIDs3 & ", " & ChMailID1
End If
End If
If ValidateEmail(ChMailID2) = False Then
If WrngIDs3 = "" Then
WrngIDs3 = ChMailID2
Else
WrngIDs3 = WrngIDs3 & ", " & ChMailID2
End If
End If
End If
End If
'Putting a space after every semi colon
TextBox3.Value = Replace(TextBox3.Value, ";", "; ")
' Checking with user whether to proceed if there are invalid mailIDs
MsgStr = ""
If WrngIDs1 <> "" Then
MsgStr = "Invalid Mail IDs found - " & Chr(13) & Chr(13) & "To: " & WrngIDs1
End If
If WrngIDs2 <> "" Then
If MsgStr = "" Then
MsgStr = "Invalid Mail IDs found - " & Chr(13) & Chr(13) & "CC: " & WrngIDs2
Else
MsgStr = MsgStr & Chr(13) & "CC: " & WrngIDs2
End If
End If
If WrngIDs3 <> "" Then
If MsgStr = "" Then
MsgStr = "Invalid Mail IDs found - " & Chr(13) & Chr(13) & "BCC: " & WrngIDs3
Else
MsgStr = MsgStr & Chr(13) & "BCC: " & WrngIDs3
End If
End If
If MsgStr <> "" Then
If MsgBox(MsgStr & vbNewLine & vbNewLine & "Please click 'Ok' to proceed or 'Cancel' to return and correct the mail IDs", vbOKCancel) = vbCancel Then
Exit Sub
Else
CheckBox2.Value = True
End If
End If
End If
'Declaring variables for use
Dim UBox, CCBox, BCCBox, SubBox, MailBodBox As String
ToBox = TextBox1.Value
CCBox = TextBox2.Value
BCCBox = TextBox3.Value
SubBox = TextBox5.Value
MailBodBox = TextBox4.Value
'Then send/display mail
'Dim oWS As Object
'Set oWS = CreateObject("WScript.Shell")
'Select Case UCase(oWS.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\CLIENTS\Mail"))
Select Case MClient
'Case "MICROSOFT OUTLOOK"
Case "MSOL"
If CheckBox3.Value = True Then MailBodBox = Replace(MailBodBox, vbCrLf, "<br/>", 1, -1, vbTextCompare)
If CheckBox3.Value = True Then MailBodBox = Replace(MailBodBox, " ", " ", 1, -1, vbTextCompare)
On Error Resume Next
With CreateObject("Outlook.Application").CreateItem(0)
If CheckBox3.Value = True Then .display
.To = ToBox
.CC = CCBox
.BCC = BCCBox
.subject = SubBox
If CheckBox3.Value = False Then .body = MailBodBox
If CheckBox3.Value = True Then .HTMLbody = "<P>" & MailBodBox & "</p>" & .HTMLbody
' attachments from userform
If ListBox1.ListCount > 0 Then
For i = 0 To ListBox1.ListCount - 1
.Attachments.Add ListBox1.List(i)
Next i
End If
If CheckBox3.Value = False Then .display
If CheckBox4.Value = True Then .Send 'If you want to send the mail without displaying, uncomment this and comment '.Display'
End With
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Outlook error! Could not create outlook mail item
!"
Exit Sub
End If
On Error GoTo 0
'Case "LOTUS NOTES" 'guesstimate - don't have Lotus Notes!
Case "LN"
On Error Resume Next
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim FileNm As String
Dim AttachME() As Object
Dim EmbedObj() As Object
Dim stSignature As String
ReDim AttachME(ListBox1.ListCount)
ReDim EmbedObj(ListBox1.ListCount)
'Debug.Print SubBox
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
'Create a new Lotus Notes document
Set NDoc = NDatabase.CreateDocument
stSignature = NDatabase.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)
With NDoc
.SendTo = ToBox
.CopyTo = CCBox
.BlindCopyTo = BCCBox
.subject = SubBox
.body = MailBodBox & stSignature
' attachments from userform
If ListBox1.ListCount > 0 Then
For i = 0 To ListBox1.ListCount - 1
FileNm = Mid(ListBox1.List(i), InStrRev(ListBox1.List(i), "") + 1, Len(ListBox1.List(i)))
Set AttachME(i) = MailDoc.CREATERICHTEXTITEM(FileNm)
Set EmbedObj(i) = AttachME(i).embedobject(1454, FileNm, ListBox1.List(i), "")
'MailDoc.CREATERICHTEXTITEM ("ListBox1.List(i)")
Next i
End If
.Save True, True, False
.display
If CheckBox4.Value = True Then .Send
.Close
End With
NUIWorkSpace.EDITDOCUMENT True, NDoc
Set NSession = Nothing
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Lotus Notes error! Could not create mail item in Lotus Notes
!"
Exit Sub
End If
On Error GoTo 0
Case Else
On Error GoTo 0
'If MsgBox("Could not find Outlook or Lotus mail client on your system! Would you like to use an SMTP based mail?", vbYesNo) = vbYes Then
'Else
MsgBox "Mail client not found! Aborting task!!!"
Exit Sub
'End If
End Select
Set oWS = Nothing
On Error GoTo 0
'Then change the counter and pass new value to field
If Cntr + 1 < ListCnt Then
Cntr = Cntr + 1
If CheckBox1.Value = True Then RunChk1 = True
If CheckBox2.Value = True Then RunChk2 = True
If CheckBox3.Value = True Then OlSign = True
If CheckBox4.Value = True Then OLSend = True
If OptionButton1.Value = True Then MClient = "MSOL"
If OptionButton2.Value = True Then MClient = "LN"
Unload Me
AppActivate "Excel"
UserForm3.Show
Else
Unload Me
Dim objLoop As Object
For Each objLoop In VBA.UserForms
If TypeOf objLoop Is UserForm Then Unload objLoop
Next objLoop
AppActivate "Excel"
MsgBox "Done"
End If
End Sub
Private Sub CommandButton3_Click()
'Change the counter and pass new value to field
If Cntr + 1 < ListCnt Then
Cntr = Cntr + 1
If CheckBox1.Value = True Then RunChk1 = True
If CheckBox2.Value = True Then RunChk2 = True
Unload Me
UserForm3.Show
Else
MsgBox "Done"
Unload Me
Dim objLoop As Object
For Each objLoop In VBA.UserForms
If TypeOf objLoop Is UserForm Then Unload objLoop
Next objLoop
End If
End Sub
' Dim myoutlook As Object ' Outlook.Application
' Dim r As Long
' Dim mymail As Object ' Outlook.AppointmentItem
' On Error Resume Next
' ' Create the Outlook session
' Set myoutlook = CreateObject("Outlook.Application")
'
' If Err.Number = 0 Then
' Err.Clear
' On Error GoTo 0
'
' ' Create the mail instance
' Set mymail = myoutlook.CreateItem(0)
'
' On Error Resume Next
' With mymail
' .to = TextBox1.Value
' .CC = TextBox2.Value
' .BCC = TextBox3.Value
' .Subject = TextBox5.Value
' .body = TextBox4.Value
'
' ' pass list of attachments to StrPath
' If ListBox1.ListCount > 0 Then
' For i = 0 To ListBox1.ListCount - 1
' .Attachments.Add ListBox1.List(i)
' Next i
' End If
' '.Send 'this will send the mail.
' .Display 'this will only display the mail
' End With
' On Error GoTo 0
' Set myoutlook = Nothing
' Set mymail = Nothing
'MAIL GENERATING CODE ENDS HERE------------------------------------------------------
'--------------------------------------------------------------------------------------
' Else
Private Sub CommandButton8_Click()
Dim intChoice As Integer
Dim w, v As Integer
'allow the user to select multiple files
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
'Set the file open title
Application.FileDialog(msoFileDialogOpen).Title = "Please select files to attach..."
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
v = Application.FileDialog(msoFileDialogOpen).SelectedItems.Count
For w = 1 To v
ListBox1.AddItem Application.FileDialog(msoFileDialogOpen).SelectedItems(w)
Next w
End If
End Sub
Private Sub CommandButton9_Click()
If ListBox1.ListIndex <> -1 Then
If MsgBox("Do you want to delete the below file from the attachment list?" & vbNewLine & vbNewLine & ListBox1.Value, vbYesNo) = vbYes Then
ListBox1.RemoveItem (ListBox1.ListIndex)
ListBox1.ListIndex = -1
Label7.Caption = ""
End If
Else
MsgBox "Select attachment to delete from List."
End If
End Sub
Private Sub ListBox1_Change()
If ListBox1.ListIndex <> -1 Then
Label7.Caption = ListBox1.Value
Else
Label7.Caption = ""
End If
End Sub
Private Sub OptionButton1_Click()
If OptionButton1.Value = True Then MClient = "MSOL"
End Sub
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then MClient = "LN"
End Sub
Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
'If UpID = True Then
If TextBox1.Value <> IDEmail(Cntr) Then
If MsgBox("Would you like to replace the mail ID '" & IDEmail(Cntr) & "' with '" & TextBox1.Value & "' in the excel sheet?", vbYesNo) = vbYes Then
Rw = Sheet2.Columns(EColNo).Find(what:=IDEmail(Cntr), LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=Falsexlwhole).Row
Sheet2.Columns(EColNo).Replace what:=IDEmail(Cntr), Replacement:=TextBox1.Value, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
On Error Resume Next
UserForm1.ListBox1.List(Rw - 4, EColNo - 3) = TextBox1.Value
IDEmail(Cntr) = TextBox1.Value
On Error GoTo 0
End If
End If
'End If
End Sub
Private Sub UserForm_Initialize()
TextBox1.Value = IDEmail(Cntr)
TextBox5.Value = MSub
TextBox2.Value = MCc
TextBox3.Value = MBcc
TextBox4.Value = "Dear " & IDUser(Cntr) & "," & Chr(13) & Chr(13) & MailBod
If RunChk1 = True Then CheckBox1.Value = True
If RunChk2 = True Then CheckBox2.Value = True
If OlSign = True Then CheckBox3.Value = True
If OLSend = True Then CheckBox4.Value = True
If MClient = "MSOL" Then OptionButton1.Value = True
If MClient = "LN" Then OptionButton2.Value = True
On Error Resume Next
If UBound(strPath) > 0 Then
For i = 0 To UBound(strPath) - 1
ListBox1.AddItem strPath(i)
Next i
End If
On Error GoTo 0
End Sub
