Userform variables to E-mail - vba

I have a Userform which has 3 buttons on it and based on the click the respective text needs to be inserted in the body of the email, for this e-mail the To, CC, Subject, will be taken from Listview box in Sheet1 which inturn extracts the values stored in Sheet2 and paste it in To, CC, Subject of the email.
When i paste the code in the buttonclick () command the variables are not getting passed from the maincode to the userform code where it shows the To, CC and Subject as blanks.
Here's the code:
Sub Worksheet_Activate()
Dim rngCell As Range
ListView41.ListItems.Clear
For Each rngCell In Worksheets("MFRs Contacts").Range("A2:A400")
If Not rngCell = Empty Then
With ListView41.ListItems.Add(, , rngCell.Value)
.ListSubItems.Add , , rngCell.Offset(0, 1).Value
.ListSubItems.Add , , rngCell.Offset(0, 2).Value
End With
End If
Next rngCell
End Sub
Sub ListView41_DblClick()
Dim strName As String
Dim strEmail As String
Dim strEmail1 As String
Dim OutApp As Object
Dim OutMail As Object
Dim Singlepart As String
Dim SigString As String
Dim Signature As String
Dim strbody As String
Dim SigFilename
strName = ListView41.SelectedItem.Text
strEmail = ListView41.SelectedItem.ListSubItems(1).Text
strEmail1 = ListView41.SelectedItem.ListSubItems(2).Text
check = MsgBox("Send e-mail, To : " & strName & " - " & strEmail & "?" & vbNewLine & _
"CC : " & strEmail1, vbYesNo)
If check <> vbYes Then Exit Sub
Singlepart = MsgBox("For Single Part or Multiple Parts ? " & vbNewLine & vbNewLine & _
"Single Part = Yes" & vbNewLine & _
"Multiple Parts = No", vbYesNo)
If Singlepart = vbYes Then
' For Single Part Numbers
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
"Please visit this website to download the new version.<br>" & _
"Let me know if you have problems.<br>" & _
"Ron's Excel Page" & _
"<br><br><B>Thank you</B>"
'Signature of User
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Rohith UTAS.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
Userform1.Show
'With Outlook
With OutMail
.Display
.To = strEmail
.CC = strEmail1
.BCC = ""
.Subject = strName & "_Request for Product Information"
.HTMLBody = strbody & vbNewLine & Signature
.Display 'or .Display if you want the user to view e-mail and send it manually
End With
Else
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Can you please help me on this.

Your variables you need to access on your form (I'm assuming strName, strEmail, and strEmail1) only have scope in Sub ListView41_DblClick(). If you need to use them in your form, you'll have to pass them as parameters (my preferred way to do it) or give them global scope.
A UserForm is a class, so you can give it properties like any other class - i.e. in UserForm1:
Private mEmail As String
Public Property Let Email(inputVal As String)
mEmail = inputVal
End Property
Public Property Get Email() As String
Email = mEmail
End Property
Then you would call it like any other object:
Dim nameless_form As UserForm1
Set nameless_form = New UserForm1
nameless_form.Email = strEmail
nameless_form.Show

Related

Outlook reply with individual recipient names (sender name of original email)

I have created a macro in Outlook VBA below that replies with the sender first name added to the greeting, adds some text for the body, and adds a signature in the fonts I want.
What I need help with is getting the macro to pull ALL of the names of the senders, assigning a value to them that I can then place elsewhere in the body of the email. If that cannot be done, I would settle for just getting all of the names into the greeting, though it is much preferred to be able to move the names around.
Example: sender was Name1;Name2
Currently, this macro will pull only Name1 (giving "Dear Name1,"), but
I would like to get to "Dear Name1 and Name2," at the very least.
Best would be able to have Name1 be in the greeting, then Name2 is placed in the body of the text.
I believe I have taken this as far as I can on my own and now turn to you experts for assistance! Thank you!!
Sub AutoAddGreetingtoReply()
Dim oMail As MailItem
Dim oReply As MailItem
Dim GreetTime As String
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim R As Outlook.Recipient
Dim strGreetName As String
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.CurrentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
strbody = "<H3><B></B></H3>" & _
"<br><br><B></B>" & _
"Please visit this website to view your transactions.<br>" & _
"Let me know if you have problems.<br>" & _
"Questions" & _
"<br><br>Thank you"
SigString = Environ("appdata") & _
"\Microsoft\Signatures\90 Days.htm"
On Error Resume Next
If Dir(SigString) <> "" Then
strGreetName = Left$(oMail.SenderName, InStr(1, oMail.SenderName, " ") - 1)
End If
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Set oReply = oMail.ReplyAll
With oReply
.CC = ""
.HTMLBody = "<Font Face=calibri>Dear " & strGreetName & "," & R1 & strbody & "<br>" & Signature
.Display
End With
End Sub
Given a string "First Last" then get the right side of the string like this
sndrName = oMail.SenderName
lastName = right(sndrName, len(sndrName) - InStr(1, sndrName, " "))
Using the format in your code:
strGreetName = Left$(oMail.SenderName, InStr(1, oMail.SenderName, " ") - 1)
lastName = right(oMail.SenderName, len(oMail.SenderName) - InStr(1, oMail.SenderName, " "))
If there is a space in the text InStr returns the position. https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/instr-function
Original mail has one sender. A ReplyAll has recipients, including the original mail sender.
Option Explicit
Private Sub ReplyFirstNames()
Dim oMail As mailitem
Dim oReply As mailitem
Dim strGreetName As String
Dim strGreetNameAll As String
Dim i As Long
Select Case Application.ActiveWindow.Class
Case olInspector
Set oMail = ActiveInspector.currentItem
Case olExplorer
Set oMail = ActiveExplorer.Selection.Item(1)
End Select
Set oReply = oMail.ReplyAll
With oReply
Debug.Print "The reply all recipients are:"
For i = 1 To .Recipients.count
Debug.Print .Recipients(i)
' Given the format First Last
strGreetName = Left(.Recipients(i), InStr(1, .Recipients(i), " ") - 1)
strGreetNameAll = strGreetNameAll & strGreetName & ", "
Next i
Debug.Print strGreetNameAll
' remove extra comma and space from end
strGreetNameAll = Left(strGreetNameAll, Len(strGreetNameAll) - 2)
Debug.Print strGreetNameAll
.htmlbody = "<Font Face=calibri>" & strGreetNameAll & .htmlbody
.Display
End With
End Sub

E-Mail notification when cell reaches date - status update does not work

I finally made it happen that my macro at least works 90%. Every time I open my Excel file, automatic e-mails are sent out to the right people.
However, I have one issue, which I cannot solve: I was hoping to implement a status, sent vs not sent, which triggers whether another e-Mail should be sent the next day.
Unfortunately, the status never updates.
I would be very happy if you can have a look at it:
Private Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim FormulaCell As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim Deadline As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
Deadline = Date
Set FormulaRange = Me.Range("S2:S64")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If .Value < Deadline Then
MyMsg = NotSentMsg
If .Offset(0, 3).Value = NotSentMsg Then
Call Mail_with_outlook1(FormulaCell)
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 3).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
Sub Mail_with_outlook1(FormulaCell As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strto = Cells(FormulaCell.Row, "T").Value
strcc = Cells(FormulaCell.Row, "U").Value
strbcc = ""
strsub = "Notice Period in 6 Months"
strbody = "Hi " & Cells(FormulaCell.Row, "D").Value & _
vbNewLine & vbNewLine & "The notice period for your customer " & Cells(FormulaCell.Row, "A").Value & " is in 180 days." & _
vbNewLine & vbNewLine & "Thank you very much and feel free to reach out to me in case of any question." & _
vbNewLine & vbNewLine & "Best regards, Marius"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Answer on comment.
Thanks Roland,
Based on your comment and the fresh mindset of the next day I finally figured it out.
I have to move the line after the first if statement 'MyMsg = NotMsgSent' to after the second if statement, Then it works perfectly fine. Thank you!

Saving Excel file as PDF then send by Outlook as Attachment but no signature in the messge

I have some Excel VBA code which save active sheet as PDF then attach that PDF file to outlook new mail everything works fine except the signature in outlook when the code starts outlook and new message it does not show the signature despite its in HTML and I can already insert it manually.
so any adjustment to the code will be appreciated.
Sub Send_To_Pdf()
Dim PdfPath As String
Dim BoDy As String
BoDy = Msg = "Dear Mr. " & vbCrLf & vbCrLf & "Good Day" & vbCrLf & vbCrLf & "Kindly find the attahched P.O to be delivered to " & Cells(10, 12)
PdfPath = Save_as_pdf
EnvoiMail Right(PdfPath, InStr(1, StrReverse(PdfPath), "\") - 1), "recepient1#domain.com;recepient2#domain.com", , , BoDy, 1, PdfPath
End Sub
Public Function Save_as_pdf() As String
Dim FSO As Object
Dim s(1) As String
Dim sNewFilePath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
s(0) = "C:\Users\" & Environ("UserName") & "\Desktop\" & ThisWorkbook.Name
If FSO.FileExists(ThisWorkbook.FullName) Then
'//Change Excel Extension to PDF extension in FilePath
s(1) = FSO.GetExtensionName(s(0))
If s(1) <> "" Then
s(1) = "." & s(1)
sNewFilePath = Replace(s(0), s(1), ".pdf")
'//Export to PDF with new File Path
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sNewFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Else
'//Error: file path not found
MsgBox "Error: this workbook may be unsaved. Please save and try again."
End If
Set FSO = Nothing
Save_as_pdf = sNewFilePath
End Function
Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
Dim MonOutlook As Object
Dim MonMessage As Object
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.createitem(0)
Dim PJ() As String
PJ() = Split(PjPaths, ";")
With MonMessage
.Subject = Subject '"Je suis content"
.To = Destina '"marcel#machin.com;julien#chose.com"
.cc = CCdest '"chef#machin.com;directeur#chose.com"
.bcc = CCIdest '"un.copain#supermail.com;une-amie#hotmail.com"
.BoDy = BoDyTxt
If PjPaths <> "" And NbPJ <> 0 Then
For i = 0 To NbPJ - 1
'MsgBox PJ(I)
.Attachments.Add PJ(i) '"C:\Mes Documents\Zoulie Image.gif"
Next i
End If
.display
'.send '.Attachments.Add ActiveWorkbook.FullName
End With '?plusieurs?MonMessage.Attachments.Add "D:\Prof\Janvier\Base clients.mdb"
Set MonOutlook = Nothing
End Sub
After a new message is created you need to insert a new text before the default signature (not to overwrite it), for example:
.BoDy = BoDyTxt
The default signature will be erased in that case.
.Body = BoDyTxt & .Body
In that case the text will be inserted in the beginning of the message leaving the signature as is.
The Outlook object model provides three different ways for working with item bodies:
Body - a plain text.
HTMLBody - an HTML markup.
The Word Editor. Outlook uses Word as an email editor, so you can use it to format the email message. The WordEditor property of the Inspector class returns an instance of the Document class which represents the message body.
You can read more about all these ways in the Chapter 17: Working with Item Bodies in MSDN.
thanks Eugene Astafiev
i changed some of the code and i got it worked after all
the changed part is as following:
Sub EnvoiMail(Subject As String, Destina As String, Optional CCdest As String, Optional CCIdest As String, Optional BoDyTxt As String, Optional NbPJ As Integer, Optional PjPaths As String)
Dim MonOutlook As Object
Dim MonMessage As Object
Dim strbody As String 'i added this part <<>>>'
Set MonOutlook = CreateObject("Outlook.Application")
Set MonMessage = MonOutlook.CreateItem(0)
strbody = "Hello" ' i put my messages here as well which i change it in my main code to get values from cells <<<<>>>'
Dim PJ() As String
PJ() = Split(PjPaths, ";")
With MonMessage
.Display ' <<<<< the most important part of the code which solved 50% of the problem >>>>'
.Subject = Subject
.To = Destina
.CC = CCdest
.BCC = CCIdest
.HTMLBoDy = strbody & "<br>" & .HTMLBoDy ' <<<< the second import part of the code and solved the other 50% >>>>> '
If PjPaths <> "" And NbPJ <> 0 Then
For i = 0 To NbPJ - 1
'MsgBox PJ(I)
.Attachments.Add PJ(i)
Next i
End If
.Display
'.send
End With
Set MonOutlook = Nothing
End Sub

Send mails in bulk rather than sending each mail immediately upon completion

I've a loop to send about 75 emails, each with an individual attachment for each individual recipient. This works, but I'm wondering how to create all these, and send them all in one go, instead of feeding them through one at a time.
I know I can use .display instead of .send to have the email show in Outlook, but is there any way to use VBA to temporarily disable sending emails, and then enable it once all mails are created?
My code looks something like this -
Dim employee_name As Variant
Dim file_path As String
Dim file_ext As String
Dim AGENT_FILE As String
Dim e As Variant
Dim email As Variant
Dim a As Integer
a = "0"
Sheets("EMAILS").Select
employee_name = Range("A1:A76").Value
file_path = "H:\Email TEST\"
file_ext = ".xlsx"
Dim OutApp As Object
Dim OutMail As Object
Dim distributionList As String
Set OutApp = CreateObject("Outlook.Application")
For Each e In employee_name
If e <> "" Then
Set OutMail = OutApp.CreateItem(0)
With Sheets("EMAILS").Select
a = a + 1
email = Range("B" & a).Value
AGENT_FILE = file_path & e & file_ext
On Error Resume Next
With OutMail
.To = email
.CC = ""
.BCC = ""
.Subject = "Daily Stats"
.Body = "Hello ," & vbCrLf & _
vbCrLf & _
"Attached are your daily stats." & vbCrLf & _
vbCrLf & _
"Regards, " & vbCrLf & _
"Oliver Lockett"
.Attachments.Add AGENT_FILE
.send
End With
End With
Set OutMail = Nothing
End If
Next
Set OutApp = Nothing
I had similar kind of stuff years ago...
I preferred using .save instead of .send. Because of this all emails where saved under drafts....once all Emails are saved....I had a macro in Outlook to send all drafts...
This can be acheived here
http://www.techrepublic.com/forum/questions/101-309127/send-all-mails-from-my-drafts-folder-at-one-go-in-outlook-2003
Why would you want to do that? Send is asynchronous, it will not block your code.

Export from Excel to Outlook

My workbook has 5 different sheets and I need to copy the five sheets and paste it into 5 different mails. Preferably as HTML.
The below written code only attaches the different sheets to outlook. I need the HTML below the body of the email. Please note that my range in the sheets varies from workbook to workbook but the sheet names remain the same.
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String
ThisFolder = BrowseForFolder()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name
If wsName <> "Data" Then
Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"
ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If
Next ws
End Sub
Sub EmailWorkbooks(RecipName, NameOfFile)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(0)
Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"
Subj = "XYZ Report" & " " & Period
On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0
End Sub
U can use Add method of PublishObjects collection, short example:
Sub InsertSheetContent()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ThisWorkbook.Worksheets
htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=htmlFile, _
Sheet:=oneSheet.Name, _
Source:=oneSheet.UsedRange.Address, _
HtmlType:=xlHtmlStatic, _
DivID:=oneSheet.Name)
onePublishObject.Publish Create:=True
Set textStream = scriptingObject.OpenTextFile(htmlFile)
htmlBody = textStream.ReadAll
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.htmlBody = htmlBody
.Display
End With
Next oneSheet
End Sub