VBA : 범위와 이미지를 이메일로 보내기

Question

나는 매일 생성하는 보고서를 가지고 있습니다. 이 보고서에는 약 7 개의 차트, 1 개의 테이블 (Excel 그룹의 일반 그룹) 및 서식이 지정된 여러 개의 병합 셀이 있습니다.

이 보고서를 자동화하기 위해 VBA 코드를 작성 했으므로이 보고서를 자동으로 전자 메일로 보내고 싶습니다. 나는 Excel에서 이메일을 보내기위한 정상적인 첫 번째 포트 인 것처럼 보이는 http://www.rondebruin.nl/을 조사했지만, 내가 찾고있는 것을 찾을 수없는 것 같습니다.

내가 복제하려고하는 기능이

• 복사 범위 ("H5 : N100")
• 주제와 전망에 새 이메일 작성이 "X"
• 특수 (메타 파일을 Enchance 붙여 넣거나 비트 맵은 일반적으로

내 문제는 내가 채워진 가방을 첨부 할 없다는 것입니다받는 사람에 "Y"를 최상의 결과를)

전자 메일 보내기를 제공합니다 e와 차트가 필요합니다. html로 변환 할 때 차트가 손실되고 특정 병합 된 셀의 기수가 이상하게 표시됩니다.

편집 : 현재

Sub Mail_Selection_Range_Outlook_Body() 

    Dim rng As Range 
    Dim Sxbdy As Range 
    Dim OutApp As Object 
    Dim OutMail As Object 



Set SxRvSht = Application.ThisWorkbook.Worksheets("Report") 


    On Error Resume Next 
    SxRvSht.Select 


    Set Sxbdy = Worksheets("Report").Range("H5:N100") 
     On Error GoTo 0 

    If Sxbdy Is Nothing Then 
     MsgBox "The selection is not a range or the sheet is protected" & _ 
       vbNewLine & "please correct and try again.", vbOKOnly 
     Exit Sub 
    End If 

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

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

    On Error Resume Next 
    With OutMail 
     .To = "EMAIL@DOMAIN.COM" 
     .CC = "" 
     .BCC = "" 
     .Subject = "SUBJECT!!!" 
     .HTMLBody = RangetoHTML(Sxbdy) 
     .display '.send 
    End With 
    On Error GoTo 0 

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

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 

Function RangetoHTML(Sxbdy As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-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 new workbook to past the data in 
    'rng.Copy 
    Set TempWB = Workbooks.Add(1) 

    Sxbdy.Copy 
    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 
    Application.CutCopyMode = False 


    'Publish the sheet to a 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 RangetoHTML 
    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 we used in this function 
    Kill TempFile 

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

을 사용하고 코드를 요청 나의 이메일 본문은 이론과 같아야합니다 - http://imgur.com/45Yic3Q 은 어떤 도움을 크게

N.B.을 감상 할 수있다 현재 Excel 2007 및 Outlook 2007을 사용 중입니다.

Answer 1

Outlook 개체 모델에 대한 참조를 포함해야하지만 매우 간단합니다. 어떤 코드를 올리면 도움이 될 것입니다. 또한 질문에 답을 표시 할 수 있도록 약간의 점수를 얻으십시오.

'vars 
Dim oApp As Outlook.Application 
Dim oMail As MailItem 
Dim wrdEdit 
'get running Outlook Application 
Set oApp = GetObject(, "Outlook.Application") 
'create a new email 
Set oMail = oApp.CreateItem(olMailItem) 
'set the subject and recipient 
oMail.Subject = "Some Subject" 
oMail.To = "Someone@somewhere.com" 
'show it 
oMail.Display 
'change to HTML 
oMail.BodyFormat = olFormatHTML 
'get the word editor 
Set wrdEdit = oApp.ActiveInspector.WordEditor 
'get the chart and copy it 
ActiveSheet.ChartObjects("Chart 1").Copy 
'paste it into the email 
wrdEdit.Application.Selection.Paste 

'release objects 
Set wrdEdit = Nothing 
Set oMail = Nothing 
Set oApp = Nothing 

Answer 2

이메일을 보내는 깔끔한 방법 이었지만 Sorceri의 대답은 내 문제를 직접 해결하지 못했습니다. 내가 사용을 찾고 있었다 솔루션 "CopyPicture 방법. 이와 같이

나는 VBE에 아웃룩 참조 (도구 >> 참고 >> 마이크로 소프트 아웃룩 12.0 개체 라이브러리)을 추가했다.

내가 다음 사용"CopyPicture를 "방법에서 사진을 얻을 수 있습니다. 우리는 아래에서 얻을 Sorceri의 대답이 점을 접합.

'vars 
Dim oApp As Outlook.Application 
Dim oMail As MailItem 
Dim wrdEdit 
'get running Outlook Application 
Set oApp = GetObject(, "Outlook.Application") 
'create a new email 
Set oMail = oApp.CreateItem(olMailItem) 
'set the subject and recipient 
oMail.Subject = "**PUT YOUR SUBJECT HERE**" 
oMail.To = "**PUT YOUR EMAIL HERE**" 
'show it 
oMail.Display 
'change to HTML 
oMail.BodyFormat = olFormatHTML 
'get the word editor 
Set wrdEdit = oApp.ActiveInspector.WordEditor 

'Copy code goes here (send keys) 
Range("**PUT YOU RANGE HERE**").CopyPicture xlPrinter, xlPicture 

'paste it into the email 
wrdEdit.Application.Selection.Paste 
oMail.Send 
'release objects 
Set wrdEdit = Nothing 
Set oMail = Nothing 
Set oApp = Nothing