如何将Thisworkbook宏分配给窗体控件

Question

I have a workbook to send out email reminders based on the due date. I would like to change it such that the macro will run when I click a button instead of running automatically when it is opened.

ThisWorkbook:

Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
    If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
Next ws
End Sub

Module1:

Option Explicit

Dim Bcell As Range
Dim iTo, iSubject, iBody As String
Dim ImportanceLevel As String

Public Sub CheckDates(ws As Worksheet)
For Each Bcell In Range("a4", Range("a" & Rows.Count).End(xlUp))

    ' if email column is not empty then command continues
    If Bcell.Offset(0, 15) <> Empty Then         

        ' mail will not be sent if current time is within 23.7 hours
        '  from time of mail last sent.
        If Now() - Bcell.Offset(0, 49) > 0.9875 Then

        If Bcell.Offset(0, 25) = Empty Then

        If DateDiff("d", Now(), Bcell.Offset(0, 13)) = 7 Then

        iTo = Bcell.Offset(0, 15)

        iSubject = Bcell & " Due"

        iBody = "<font face=""Calibri"" size=""3"">" & "Dear all,<br/><br/>" & _
        "<u>FR No. " & Bcell & "</u><br/><br/>" & "Please be reminded that " & Bcell & " will be due by <b><FONT COLOR=#ff0000>" & _
        Bcell.Offset(0, 13) & "</font></b>." & _
        " Kindly ensure that the FR is closed by the due date and provide the draft FR report with preliminary investigation (Section B & D filled) to Quality.<br/><br/>" _
        & "Thank you<br/><br/>" & "Best Regards,<br/>" & "Quality Department<br/><br/>" _
        & "company Pte Ltd.<br/>" & "</font>"

        SendEmail
        Bcell.Offset(0, 49) = Now()

        End If
        End If
        End If
    End If
            iTo = Empty
            iSubject = Empty
            iBody = Empty
    Next Bcell

End Sub



Private Sub SendEmail()

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


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next

    With OutMail
        .To = iTo
        .CC = "email@email.com"
        .BCC = ""
        .Subject = iSubject
        .HTMLBody = iBody
        .Importance = ImportanceLevel
        'You can add a file like this
        '.Attachments.Add ("C:\test.txt")
        .send

    End With

    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Answer 1

You have two ways to accomplish this depending on the type of button you want to use to run the macro:

a) If the button is a simply Shape (Insert > Shapes), you need to move the contents of Workbook_Open to a new sub within your Module1 (let's call it "trigger") and right-click the shape > Assign macro > "trigger".

Sub trigger()
        Dim ws As Worksheet
        For Each ws In ThisWorkbook.Worksheets
            If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
            End If
        Next ws
End Sub

b) If the button is not a shape but a form button, you need to double-click it while on the design view and move the contents of "trigger" to its own click sub (CommandButton1_click()).

c) Finally, remember to remove the contents of Workbook_Open() sub.