Hi Friends,
I'm having a trouble in these 3 codes. I'd like to integrate the code of Dinesh Takyar and the code from Rondebruin and the code from an attachment but I'm stuck in incorporating these codes into one.
What I want to happen is that:[LIST=1][*]I'll be able to send emails to different recipients with different worksheets- For example: in the Master File, named, "Outdated", the recipient, 21 QUEEN REALTY & BROKERAGE has 2 names in the supplier column BUT if you check their rows it has different values.
What will happen is that this will be put in one worksheet (parsing the data). The same will happen with the others in the Supplier column).
After this will be put in one worksheet, this worksheet will be sent out to the email of 21 QUEEN REALTY & BROKERAGE ie. in the last column BUT in the column of email addresses (Column O) it is the same like the Supplier column wherein it is duplicated or it just don't occur once but many times.
Lastly, the excel worksheet will be sent as an attachment to the recipient.
- In the sample attachment, you will see the tab, SalesRpt. That sample template is what I want to use with the message I want to tell to the recipient and the data for the worksheet(s).
- The recipient may be one or many. The same goes for the sender, it may be one or many.
- There will be like a Menu that can be setup the sender(s)' email address(es) or one sender then use either BCC or CC. Also the content, subject will be setup in the same menu.
Just like the code in the attachment: emailtestfile 2.xlsm. - There will be a copy of the excel worksheet on the folder I want to use (able to browse just like when saving any file, we will be prompt on where to save the file).
These are the problems I encountered when I setup the file:- The file keeps on crashing that's why I need help so I am now starting from scratch.
- I tried on integrating the 3 codes but I'm having a hard time because one code is that the subject, body, sender and recipient cannot be edited because it is inside the module, it is not linked to any cell or range. The other one is linked to outlook and the attachment(s) are in pdf. I tried to change the xltypePDF to xltypeXLS or xltypeXLSX but to no avail, it is not working. The other one, I tried using the codes' attachment: Attachment 389737 but I'm having a hard time in changing it even the template when it is being sent out.
These are the codes that I find useful for the output that I want:
From Dinesh Takyar:
Sub send_email_via_Gmail()
Dim myMail As CDO.Message
Set myMail = New CDO.Message
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpusessl”) = True
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpauthenticate”) = 1
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserver”) = “smtp.gmail.com”
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserverport”) = 25
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusing”) = 2
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusername”) = “[email protected]”
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendpassword”) = “password”
myMail.Configuration.Fields.Update
With myMail
.Subject = “Test Email from Dr. Takyar”
.From = “[email protected]”
.To = “[email protected]; [email protected]”
.CC = “[email protected]”
.BCC = “”
.TextBody = “Good morning!”
.AddAttachment “C:\Users\takyar\Desktop\email-via-gmail.txt”
End With
On Error Resume Next
myMail.Send
‘MsgBox(“Mail has been sent”)
Set myMail = Nothing
End Sub
Using Yahoo with VBA:
Sub email_using_Yahoo_VBA()
Dim myMail As CDO.Message
Set myMail = New CDO.Message
‘Enable SSL Authentication
myMail.Configuration.Fields.Item _
(“http://schemas.microsoft.com/cdo/configuration/smtpusessl”) = True
‘SMTP authentication Enabled
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpauthenticate”) = 1
‘Set the SMTP server and port details
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserver”) = “smtp.mail.yahoo.com”
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/smtpserverport”) = 465
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusing”) = 2
‘Set your username and password for your Yahoo Account
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendusername”) = “[email protected]”
myMail.Configuration.Fields.Item(“http://schemas.microsoft.com/cdo/configuration/sendpassword”) = “password”
‘Update all configuration fields
myMail.Configuration.Fields.Update
‘Set the email properties
With myMail
.Subject = “Test Mail from Dr. takyar”
.From = “[email protected]”
.To = “[email protected]; [email protected]”
.CC = “[email protected]”
.BCC = “”
.TextBody = “Welcome to MS Excel Training!”
End With
myMail.Send
MsgBox (“Mail sent”)
‘Set myMail Variable to Nothing to free memory
Set myMail = Nothing
End Sub
Code from Rondebruin:
Sub Mail_sheets()
Dim MyArr As Variant
Dim last As Long
Dim shname As Long
Dim a As Integer
Dim Arr() As String
Dim N As Integer
Dim strdate As String
For a = 1 To 253 Step 3
If ThisWorkbook.Sheets("mail").Cells(1, a).Value = "" Then
Exit Sub
End
Application.ScreenUpdating = False
last = ThisWorkbook.Sheets("mail").Cells(Rows.Count, _
a).End(xlUp).Row
N = 0
For shname = 1 To last
N = N + 1
ReDim Preserve Arr(1 To N)
Arr(N) = ThisWorkbook.Sheets("mail").Cells(shname, a).Value
Next shname
ThisWorkbook.Sheets(Arr).Copy
strdate = Format(Date, "dd-mm-yy") & " " & _
Format(Time, "h-mm-ss")
ActiveWorkbook.SaveAs "Part of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
With ThisWorkbook.Sheets("mail")
MyArr = .Range(.Cells(1, a + 1), .Cells(Rows.Count, _
a + 1).End(xlUp))
End With
ActiveWorkbook.SendMail MyArr, ThisWorkbook.Sheets("mail").Cells(1, a + 2).Value
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ActiveWorkbook.Close False
Application.ScreenUpdating = True
Next a
End Sub
Code from the attachment: emailtestfile 2.xlsm
In Module: modFiles
Option Explicit
Sub SendEmailTest()
SendEmailWithPDF (True)
End Sub
Sub SendEmailStores()
SendEmailWithPDF (False)
End Sub
Sub SendEmailWithPDF(bTest As Boolean)
Dim wsM As Worksheet
Dim wsL As Worksheet
Dim wsR As Worksheet
Dim wsS As Worksheet
Dim rngL As Range
Dim rngSN As Range
Dim rngPath As Range
Dim c As Range
Dim lSend As Long
Dim lCount As Long
Dim OutApp As Object
Dim OutMail As Object
Dim strSavePath As String
Dim strPathTest As String
Dim strPDFName As String
Dim strSendTo As String
Dim strSubj As String
Dim strBody As String
Dim strMsg As String
Dim strConf As String
On Error GoTo errHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
strMsg = "Could not set variables"
Set wsM = wksMenu
Set wsS = wksSet
Set wsL = wksList
Set wsR = wksRpt
Set rngL = wsL.Range("StoreNums")
Set rngSN = wsR.Range("rngSN")
Set rngPath = wsS.Range("rngPath")
lCount = rngSN.Cells.Count
If bTest = True Then
strConf = "TEST Emails: "
Else
strConf = "STORE Emails: "
End If
strConf = strConf & wsS.Range("rngCountMail").Value
strConf = strConf & vbCrLf & vbCrLf
strConf = strConf & "Please confirm: Do you want to send the emails?"
lSend = MsgBox(strConf, vbQuestion + vbYesNo, "Send Emails")
If lSend = vbYes Then
strSubj = wsS.Range("rngSubj").Value
strBody = wsS.Range("rngBody").Value
strSendTo = wsS.Range("rngSendTo").Value
strSavePath = rngPath.Value
strMsg = "Could not test Outlook"
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
On Error GoTo errHandler
If OutApp Is Nothing Then
MsgBox "Outlook is not open, open Outlook and try again"
GoTo exitHandler
End If
strMsg = "Could not set path for PDF save folder"
If Right(strSavePath, 1) <> "\" Then
strSavePath = strSavePath & "\"
End If
If DoesPathExist(strSavePath) Then
'continue code below, using strSavePath
Else
MsgBox "The Save folder, " & strSavePath _
& vbCrLf & "does not exist." _
& vbCrLf & "Files could not be created." _
& vbCrLf & "Please select a valid folder."
wsS.Activate
rngPath.Activate
GoTo exitHandler
End If
strMsg = "Could not start mail process"
For Each c In rngL
rngSN = c.Value
strMsg = "Could not create PDF for " & c.Value
strPDFName = "SalesReport_" & c.Value & ".pdf"
If bTest = False Then
strSendTo = c.Offset(0, 3).Value
End If
wsR.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strSavePath & strPDFName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set OutMail = OutApp.CreateItem(0)
strMsg = "Could not start mail process for " & c.Value
On Error Resume Next
With OutMail
.To = strSendTo
.CC = ""
.BCC = ""
.Subject = strSubj
.Body = strBody
.Attachments.Add strSavePath & strPDFName
.Send
End With
On Error GoTo 0
Next c
Application.ScreenUpdating = True
wsM.Activate
MsgBox "Emails have been sent"
End If
exitHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set OutMail = Nothing
Set OutApp = Nothing
Set wsM = Nothing
Set wsS = Nothing
Set wsL = Nothing
Set wsR = Nothing
Set rngL = Nothing
Set rngSN = Nothing
Set rngPath = Nothing
Exit Sub
errHandler:
MsgBox strMsg
Resume exitHandler
End Sub
Function DoesPathExist(myPath As String) As Boolean
Dim TestStr As String
If Right(myPath, 1) <> "\" Then
myPath = myPath & "\"
End If
TestStr = ""
On Error Resume Next
TestStr = Dir(myPath & "nul")
On Error GoTo 0
DoesPathExist = CBool(TestStr <> "")
End Function
Sub GetFolderFilesPDF()
Dim rngPath As Range
On Error Resume Next
Set rngPath = wksSet.Range("rngPath")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
rngPath.Value = .SelectedItems(1)
End If
End With
End Sub
Sub TestOutlook()
Dim oOutlook As Object
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If oOutlook Is Nothing Then
MsgBox "Outlook is not open, open Outlook and try again"
Else
'Call NameOfYourMailMacro
End If
End Sub
In Module: modNav
Option Explicit
Sub GoMenu()
On Error Resume Next
wksMenu.Activate
End Sub
Sub GoSettings()
On Error Resume Next
With wksSet
.Activate
.Range("rngSubj").Activate
End With
End Sub
Please see my file in this link: https://www.dropbox.com/s/lnsbdxo9di...mple.xlsm?dl=0
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks