Excel加载项/宏以发送大量电子邮件

Question

So I have a task to automate. We have a protected spreadsheet (users only have 'read' access to) that get's updated by admins from time to time in order to add/remove users from a paid subscription mailing list. I'm trying to make the process of sending these emails out simpler to speed up the process and eliminate the potential of human error getting involved.

So email addresses are listed under the 'C' column, lists can be as long as in the tens of thousands, or it may only be 1 or 2. The workbook has several sheets that specify the data set that the subscribers subscribe to. So I put something together that worked

'This function will grab the information the macro asks for
Function RangeToString(ByVal myRange As Range) As String
RangeToString = ""
If Not myRange Is Nothing Then
    Dim myCell As Range
    For Each myCell In myRange
        RangeToString = RangeToString & "; " & myCell.Value
    Next myCell
    'Remove extra comma
    RangeToString = Right(RangeToString, Len(RangeToString) - 1)
End If
End Function

---

Sub EmailTest1()
Dim OutApp As Object
Dim OutMail As Object
Dim strSubject As String
Dim myString As String
Dim rng As Range
Dim strCopy As String

'Sheet1 would be Sheet2/3/4/etc. depending on what list we're pulling from.
Set rng = Sheet1.Range("c2:c90000")
myString = RangeToString(rng)
strCopy = "internal.private@email.com; internal1.private@email.co; 
internal2.private@email.co"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\Domain\EmailTemplate\oft\test1.oft")

On Error Resume Next
With OutMail
    .BCC = myString + strCopy
    .Display
    '.Send
End With

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Then I had repeats of the second part that specify the different lists/email templates as individual macros within the Add-In. (.Send will not be commented out when I do finally get the results I want).

So this works perfectly, when the macro specifies and embeds a workbook into itself. So for a while, I thought that it was pulling everything fine, until I used a blank workbook, and it still pulled the data I wanted, so I checked and double checked that there was no reference to the original workbook, and then I discovered that the workbook was built into the macro. I tried rebuilding the add-in using the same code, and it just doesn't work.

So my question is, is there a way to build this macro so that it'll work on any active workbook? I imagine there has got to be a simple thing to click on or something else I'm overlooking. I'm working with Excel 2016.

Answer 1

first of all, why didn't you just make a macro-embedded template where you have a form that connects any active workbook.

dim ws as workbook

set ws=activeworkbook

so basically make a form that is modular then on a label click event put that code.

then an execute button so that you can determine if you connect the right workbook before you start the email sending automation

Answer 2

I think you can adapt this to suit your needs.

Make a list in Sheets("Sheet1") with :

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B and file name(s) in column C:Z it will create a mail with this information and send it.

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

https://www.rondebruin.nl/win/s1/outlook/amail6.htm