3
最近、コマンドボタンをクリックしたときに特定の人にメールを送信できるコードを書いています。私のコードはもともとうまくいきましたが、私はこれらの人々の電子メールの範囲を、アクティブなシートの代わりに "パラメータ"という名前の別のシートで参照したかったのです。は、vbaを通じて自動メールを送信するためのコードを修正するのに役立つ必要があります
私のコードを変更したとき、それは働いたが、1つの電子メールを送信するのではなく、3つ送信した。私は1つの電子メールを送信するようにコードを終了するのに役立つ必要があります。
Private Sub JLechner_Click()
Dim sh As Worksheet
Dim sh2 As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set sh2 = ThisWorkbook.Sheets("Parameter")
For Each sh In ThisWorkbook.Worksheets
If sh2.Range("K8").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
strbody = "(See below for english version)" & vbNewLine & vbNewLine & _
"Hallo," & vbNewLine & vbNewLine & _
"Maß " & sh.Range("E4").Value & " muss geprüft werden." & vbNewLine & _
"Bitte im Sharepoint die prüfung durchführen." & vbNewLine & vbNewLine & _
"Die Maßnahmenblätter finden Sie unter folgendem Link:" & vbNewLine & vbNewLine & _
"Wenn die Prüfung abgeschlossen ist, bitte die Taste auf der rechten Seite der tabelle drücken, um die Maßnahme zum folgendem Bearbeiter weiterzuleiten." & vbNewLine & _
"Wenn Sie Unterstützung brauchen, bitte kontaktieren Sie Bob and Ryan." & vbNewLine & vbNewLine & _
"Vielen Dank." & vbNewLine & _
"Mit freundlichen Grüßen" & vbNewLine & _
"Team" & vbNewLine & vbNewLine & vbNewLine & _
"----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------" & vbNewLine & vbNewLine & vbNewLine & _
"Hello," & vbNewLine & vbNewLine & _
"Measure " & sh.Range("E4").Value & " must be checked." & vbNewLine & _
"Please access the Sharepoint and proceed with your corresponding check." & vbNewLine & vbNewLine & _
"Measures can be found using the following link:" & vbNewLine & vbNewLine & _
"When finished, please forward the measure to the next responsible person using the buttons on the right side of the table." & vbNewLine & _
"If you require support, contact any MTM responsible persons." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & _
"Best regards," & vbNewLine & _
"Team"
On Error Resume Next
With OutMail
.To = sh2.Range("K8").Value
.CC = ""
.BCC = ""
.Subject = "Bitte Maßnahmenblatt bearbeiten: " & sh.Range("E4").Value
.Body = strbody
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
私にこれを手伝ってもらえるか教えてください。