Блог

Это код, который нажимает кнопку:

 Sub a()
    Dim btn As Button 
    Application.ScreenUpdating = False
    ActiveSheet.Buttons.Delete
    Dim t As Range


        For i = 1 To 3
        Set t = ActiveSheet.Range(Cells(i, 3), Cells(i, 3))
        Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
        With btn
         .OnAction = "btnS"
         .Caption = "Btn " amp; i
         .Name = "Btn" amp; i
   End With
Next i

Application.ScreenUpdating = True

End Sub

Sub btnS()
    MsgBox Application.Caller
End Sub
  

Это код для массовой отправки электронной почты:

 Sub SendEmail(address_mail As String, subject_mail As String, mail_body As String)


Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)

    olMail.To = address_mail
    olMail.Subject = subject_mail
    olMail.Body = mail_body

   On Error GoTo Cancel

    olMail.Send

Cancel:

End Sub
Sub SendMassEmail()

Dim addressString As String
addressString = ""
row_number = 2



Do
DoEvents

    row_number = row_number   1
    addressString = addressString amp; Application.ActiveSheet.Range("C" amp; row_number) amp; ";"


    Loop Until row_number = 999
Call SendEmail(addressString, Application.ActiveSheet.Range("F9"), Application.ActiveSheet.Range("F10"))

End Sub
  

Я действительно не понимаю, почему вы должны привязывать оба кода к одному. Было бы признателен, если бы вы могли немного прояснить это.

Поскольку, пока оба кода находятся в одном модуле, вы можете просто создать новый подраздел и запустить его при необходимости, который будет запускать оба ваших кода один за другим:

 Sub Bind()
Call a ' runs the first code
Call SendEmail ' runs the sendemail code
Call SendMassEmail ' runs the sendmassemail code
End Sub
  

Выше будут запущены все три кода один за другим. Вы можете перетасовать порядок по своему усмотрению.

Редактировать:

Хорошо, итак, из того, что я понял из ваших комментариев, вам нужен один подраздел, который создаст 1 кнопку, при нажатии на которую будут отправляться электронные письма.

Предположим, что со вторым кодом все в порядке, это то, что вы делаете:

 Sub a()
    Dim btn As Button
    Application.ScreenUpdating = False
    ActiveSheet.Buttons.Delete
    Dim t As Range

r = 1 ' select the row number where you want to create the button
c = 3 ' select the column number where you want to create the button

        Set t = ActiveSheet.Range(Cells(r, c), Cells(r, c))
        Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
        With btn
         .OnAction = ActiveSheet.Name amp; ".SendEmail" ' select the name of your second code here.
         .Caption = "Btn"
         .Name = "Btn"
   End With

Application.ScreenUpdating = True

End Sub
  

Таким образом, на активном листе создается кнопка, при нажатии на которую запускается ваш второй код, который должен выполнять необходимое (при условии, что ваш второй код также находится на том же листе).

Я надеюсь, что это то, что вы искали!’

РЕДАКТИРОВАТЬ 2:

Из ваших комментариев кажется, что вам нужно простое объединение почты. Если это так, то, пожалуйста, прочитайте больше о «слиянии почты», поскольку это намного проще и предложит больше функциональности.

То, что вы просите, можно сделать в Excel, но это намного сложнее, и вот как:

1. Создайте 2 листа: (Лист1) Имена и электронные письма (Лист2) Тема и тело
2. Добавьте кнопку ActiveX на листе: Тема и тело
3. Сделайте так, чтобы это выглядело следующим образом:

Лист1 http://im63.gulfup.com/Bp8nJx.png
Лист2 http://im63.gulfup.com/PtKK46.png

Наконец, добавьте следующий код к вашей кнопке:

 Private Sub CommandButton1_Click()


LastRow = Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row 'find the last filled row with emails

For Each Cell In Worksheets("Names amp; Emails").Range("B2:B" amp; LastRow) 'sets the range of cells with emails
    If Cell.Value = "" Then GoTo Line1 'loop until a blank cell is reached i.e. lastrow
    x = x amp; Cell.Value amp; "; " 'appends all the email in one line while adding "; " in between
Next

Emails = Left([x], Len([x]) - 2) 'removes the last 2 characters ("; ") from the appended string as the seperator is not needed after the last email

Line1:

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OlObjects = OutApp.GetNamespace("MAPI")
    Set OutMail = OutApp.CreateItem(olMailItem)

On Error Resume Next
    With OutMail
        .To = Emails 'inserts the appended line in the To field
        .Subject = Worksheets("Subject amp; Body").Range("B2").Value 'uses the value of B2 as the Subject of the Email
        .Body = Worksheets("Subject amp; Body").Range("B5").Value 'uses the value of B5 as the Body of the Email
        '.Display 'you can enable this line if you need to view the email before it's sent
        .Send 'sends the email
    End With

x = ""

End Sub
  

Теперь всякий раз, когда вы нажимаете кнопку, она отправляет электронное письмо на все адреса в списке с темой и телом, которые вы выберете.