Excel 2013 VBA - Oulook 전자 메일을 채우는 전자 메일 수신자 목록 (TO 및 CC) 설정

Question

데이터를 Incident Details 데이터 시트에 저장하고 'Email Form'워크 시트에 데이터를 임시 저장하는 Userform을 설정했습니다. '전자 메일 양식'이 MS Outlook 전자 메일 본문에 복사되도록 양식과 같이 배치됩니다.

이 완벽하게 작동, 내가 제공 한 현재의 코딩 1받는 사람에게 하나의 이메일 을 보내고 가 다른를 참조로 추가,하지만 난 여러 명의받는 사람에게 같은 이메일을 보낼 필요가있다. 필자는 필요에 따라 목록을 쉽게 업데이트하기를 원하기 때문에 '전자 메일받는 사람 목록 (동일한 통합 문서)'이라는 다른 시트를 만들었습니다. 사용자 중 누구도 VBA에서 하드 코드를 편집 할 수 없습니다. 열 A에는받는 사람 목록이 있고 열 B에는 참조받는 사람 목록이 있습니다.

여러 동영상과 사이트를 검색하여 보았지만 '이메일 수신자 목록'시트에서 해당 목록을 추출하고 기존 작업에 영향을주지 않으면 서 Outlook 이메일을 채우는 방법을 연습 할 수 없었습니다. 코드가 Outlook 전자 메일을 열기 때문에 사용자가 매크로 단추를 클릭하는 것을 원하지 않습니다.

이 기존 코드 :

Sub log_send_reset() 
'THIS OPENS OUTLOOK WITH DETAILS OF FORM 

'WORKS with "Email Form" 
Dim SecIncNo As String 

'This bit emails the current worksheet in the body of an email as HTML 
'#If 0 Then 
Dim rng As Range 
Dim OutApp As Object 
Dim OutMail As Object 

Set rng = Nothing 
On Error Resume Next 

Set rng = Sheets("Email Form").Range("A1:AB119") 
On Error GoTo 0 

With Application 
    .EnableEvents = False 
    .ScreenUpdating = True 'ShyButterfly set this to TRUE (it was false) 
End With 

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

On Error Resume Next 
With OutMail 

'This bit tells it where to send the email to, what the subject line is etc 

.to = "246abc@company.com" 

.CC = "rep3@company2.com" 
.BCC = "" 
.Subject = Range("H6").value & " - " & "SAC" & Range("G12").value & " - " & Range("G14").value & " - " & Range("H8").value 
    .HTMLBody = RangetoHTML(rng) 
    'Shybutterfly changed from.Send to .Display to see what it does 
    .Display 
'or use .Display if you want to edit/add text before sending 

End With 
On Error GoTo 0 

With Application 
    .EnableEvents = True 
    .ScreenUpdating = True 
End With 

Set OutMail = Nothing 
Set OutApp = Nothing 


ThisWorkbook.Save 

'ThisWorkbook.Close 

'Application.Quit 


End Sub 

내가 어떤 도움을 감사하겠습니다.

Answer 1

이렇게하면받는 사람 목록을 만들 수 있습니다. 당신이 변수가 오류를 정의되지 얻을 것 곳

EmailTo = getRecipients (1)

EmailCC = getRecipients (2)

Function getRecipients(vColumn As Variant) As String 
    Dim rListColumn As Range 
    Dim c As Range 
    Dim s As String 
    With Worksheets("Email Recipient List") 

     Set rListColumn = .Range(.Cells(2, vColumn), .Cells(Rows.Count, vColumn).End(xlUp)) 

     For Each c In rListColumn 
      s = s & c.Text & ";" 
     Next 

     getRecipients = Left(s, Len(s) - 1) 
    End With 

End Function 

나는 보지 못했다. getRecipients가 전용 모듈에 있으면 하위 또는 함수 정의 오류가 발생합니다.

코드를 리팩터링했습니다. 코드 모듈에서 이걸 직접 실행하고 ComposeEmail을 실행하십시오.

 
    Option Explicit 
    Public Sub ComposeEmail() 

     ToggleEvents False 

     Dim EmailTo As String, CC As String, BCC As String, Subject As String, HTMLBody As String, ShowEmail As Boolean 
     Dim rng As Range 

     ToggleEvents False 

     Set rng = Sheets("Email Form").Range("A1:AB119") 

     EmailTo = getRecipients(1) 
     CC = getRecipients(2) 
     'BCC = getRecipients(2) 
     Subject = Range("H6").Value & " - " & "SAC" & Range("G12").Value & " - " & Range("G14").Value & " - " & Range("H8").Value 
     HTMLBody = RangetoHTML2(rng) 
     ShowEmail = True 

     SendMail EmailTo, CC, BCC, Subject, HTMLBody, ShowEmail 

     ' ThisWorkbook.Close True 'This Line save and Closes the workbook 

     ToggleEvents True 

    End Sub 

    Function getRecipients(vColumn As Variant) As String 
     Dim rListColumn As Range 
     Dim c As Range 
     Dim s As String 
     With Worksheets("Email Recipient List") 

      Set rListColumn = .Range(.Cells(2, vColumn), .Cells(Rows.Count, vColumn).End(xlUp)) 

      For Each c In rListColumn 
       s = s & c.Text & ";" 
      Next 

      getRecipients = Left(s, Len(s) - 1) 
     End With 

    End Function 

    Public Sub SendMail(EmailTo As String, CC As String, BCC As String, Subject As String, HTMLBody As String, ShowEmail As Boolean) 
     Dim OutApp As Object 
     Dim OutMail As Object 
     Set OutApp = CreateObject("Outlook.Application") 
     Set OutMail = OutApp.CreateItem(0) 
     With OutMail 
      .to = EmailTo 
      .CC = CC 
      .BCC = BCC 
      .Subject = Subject 
      .HTMLBody = HTMLBody 

      If ShowEmail Then 
       .Display 
      Else 
       .Send 
      End If 

     End With 

     Set OutMail = Nothing 
     Set OutApp = Nothing 
     Exit Sub 
    EmailCouldNotBeCreated: 
     MsgBox "Email could not be created", vbCritical, "Error in Sub SendMail" 
    End Sub 

    Sub ToggleEvents(bEnableEvents As Boolean) 
     With Application 
      .EnableEvents = bEnableEvents 
      .ScreenUpdating = bEnableEvents 
     End With 
    End Sub 


    ' https://msdn.microsoft.com/en-us/library/ff519602%28v=office.11%29.aspx?f=255&MSPPError=-2147217396 

    Function RangetoHTML2(rng As Range) 
    ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. 
     Dim fso As Object 
     Dim ts As Object 
     Dim TempFile As String 
     Dim TempWB As Workbook 

     TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm" 

     ' Copy the range and create a workbook to receive the data. 
     rng.Copy 
     Set TempWB = Workbooks.Add(1) 
     With TempWB.Sheets(1) 
      .Cells(1).PasteSpecial Paste:=8 
      .Cells(1).PasteSpecial xlPasteValues, , False, False 
      .Cells(1).PasteSpecial xlPasteFormats, , False, False 
      .Cells(1).Select 
      Application.CutCopyMode = False 
      On Error Resume Next 
      .DrawingObjects.Visible = True 
      .DrawingObjects.Delete 
      On Error GoTo 0 
     End With 

     ' Publish the sheet to an .htm file. 
     With TempWB.PublishObjects.Add(_ 
      SourceType:=xlSourceRange, _ 
      Filename:=TempFile, _ 
      Sheet:=TempWB.Sheets(1).Name, _ 
      Source:=TempWB.Sheets(1).UsedRange.Address, _ 
      HtmlType:=xlHtmlStatic) 
      .Publish (True) 
     End With 

     ' Read all data from the .htm file into the RangetoHTML subroutine. 
     Set fso = CreateObject("Scripting.FileSystemObject") 
     Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) 
     RangetoHTML = ts.ReadAll 
     ts.Close 
     RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ 
           "align=left x:publishsource=") 

     ' Close TempWB. 
     TempWB.Close savechanges:=False 

     ' Delete the htm file. 
     Kill TempFile 

     Set ts = Nothing 
     Set fso = Nothing 
     Set TempWB = Nothing 
    End Function 

Answer 2

어느받는 사람 각각 MailItem.Recipients.Add 전화는 (은받는 사람 개체를 반환 적절하게 olTo/olCC/olBCC과의 Recipient.Type 속성을 설정)에받는 사람/CC/BCC 속성을 설정하는 ";" 분리 된 주소 목록.