VBA - シートをOutlookの電子メールにコピーする

私はVBAを初めて使用し、電子メールを送信する次のコードを作成しました。私の質問は、私が現在エクセルファイル内に貼り付けるために使用している私のExcelシートからいくつかのセルをコピーする方法です。VBA - シートをOutlookの電子メールにコピーする

おかげで、

Sub CIR_Save_Email() 

Dim objoutlook As Object 
Set objoutlook = CreateObject("outlook.application") 

Dim objemail As Object 
Set objemail = objoutlook.createitem(olmailitem) 
Const olFormatHTML As Long = 2 

emailbodymessage = "<HTML><BODY>Hi Team," & _ 
"<br><br>Attached is the Display's CIR for today<br><br>" & _ 
"<b>Brief overview of CIR</b><br><br>" & _ 
"<b>Purpose:</b> To get a snapshot of what your current inventory levels by SKU are every day." & _ 
"<ul style=""list-style-type:circle"">" & _ 
    "<li><b>Unrestricted QTY</b> The total inventory at that DC (i.e.Deliveries Created + Available Qty)</li>" & _ 
    "<li><b>Deliveries Created:</b> Orders that are being processing at that DC (i.e. they will NOT be included in Available Inventory)</li>" & _ 
    "<li><b>Available:</b> How many cases are available to use at that DC </li>" & _ 
    "<li><b>Avail DOS:</b> How many DOS the available cases equate to</li>" & _ 
"<li><b>IT QTY:</b> How man cases are in transit</li>" & _ 
"<li><b>Avail +IT DOS:</b> How many DOS the available cases equate to</li>" & _ 
"</ul> </body> </html>" 

emailbodymessage2 = "<html><body><ul style=""list-style-type:circle"">" & _ 
"<li><b>Future Available:</b> The total DOS of cases Avail + IT</li>" & _ 
"<li><b>QI QTY:</b> How many cases are on Qualitiy (ie Non-Conformance)</li>" & _ 
"<li><b>Blocked QTY:</b> How many cases are blocked from ordering due to damages, short dating, expired, etc." & _ 
"<li><b>CM- months:</b> The forecasts of the months past (CM-1=July)</li>" & _ 
"<li><b>% to Fcst:</b> How much of your projected forecast has shipped this month</li>" & _ 
"<li><b>Current SNAP Fcst:</b> This month's projected forecast</li>" & _ 
"<li><b>CM+ months:</b> The forecasts of the months moving forward (CM+1= September)</li>" & _ 
"</ul> </body></html>" 

With objemail 
    .To = emaillist 
     .cc = "" 
    .Subject = "Display's CIR " & Date 
    .BodyFormat = olFormatHTML '// 2 
.HTMLBody = emailbodymessage & emailbodymessage2 

.display 

End With 

End Sub

出典

2017-10-19 Roz_sxo

あなたは電子メールの本文内のいくつかの追加コンテンツを挿入する方法を求めていますか？ところで、あなたの2つのHTMLセグメントそれぞれが完全なオープン/クローズのタグを持っている（つまり、それぞれが完全なHTML「ページ」です） - 'html'と' body'タグ） –

はい私はあなただけの開口部の1セットとクローズの1セットが必要ワークシートのコピーされたセルをメッセージの本文にどのように追加するのかを見つけようとしています。 HTMLタグの入力のためのありがとう！ –

あなたが含める必要があるものをもう少し正確に説明する必要があります：全範囲？なんて大きい？または個々の値だけ？メールのどこに行く必要がありますか？ C5：私は複数のセルにまたがるExcelの表をコピーしたい –

あなたがHTMLにExcelの範囲を変換するには、次の関数（内部でHTMLにエクスポートする範囲を使用しています）を使用することができます。結果として得られるHTMLは、生成されたHTML本体に含める必要があります。

この関数は、HTMLの一時作成ファイルにRangeを書き出してから、コンテンツを（周囲のHTMLタグなしで）divのみに取り除きます。

ただし、フォーマットやその他の詳細が要件に合うかどうかはわかりません。他の解決策は、手動でセルからHTMLを構築することですが、はるかに多くの作業が必要です。

使用法：str = GetHtml("Sheet1","D4:E6")

Public Function GetHtml(ByVal sheetName As String, ByVal rangeName As String) As String 
Dim fso As FileSystemObject 
Dim fileName As String 
Dim txtStream As TextStream 
Dim html As String 
Dim line As String 
Dim readLines As Boolean 

Set fso = New FileSystemObject 

Dim rng As range 
fileName = fso.GetSpecialFolder(2) & "\" & Replace(fso.GetTempName, ".tmp", ".html") 
If fso.FileExists(fileName) Then 
    fso.DeleteFile fileName 
End If 

Set rng = Sheets(sheetName).range(rangeName) 

ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, fileName:=fileName, Sheet:=rng.Worksheet.Name, Source:=rng.Address, HtmlType:=xlHtmlStatic).Publish 
Set txtStream = fso.OpenTextFile(fileName, ForReading, False) 

readLines = False 
html = "" 
Do While Not txtStream.AtEndOfStream 
    line = txtStream.ReadLine 
    If InStr(line, "<!--START OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then 
     readLines = True 
    End If 
    If readLines Then 
     html = html & vbCrLf & line 
    End If 
    If readLines And InStr(line, "<!--END OF OUTPUT FROM EXCEL PUBLISH AS WEB PAGE WIZARD") > 0 Then 
     readLines = False 
    End If 
Loop 
txtStream.Close 
Set txtStream = Nothing 

If fso.FileExists(fileName) Then 
    fso.DeleteFile fileName 
End If 
Set fso = Nothing 

GetHtml = html 

End Function

出典

2017-10-20 08:31:45 smartobelix

あなたは「私は現在、Excelファイル内貼り付ける使用しています私のExcelシートからのいくつかのセルをコピー」したいと述べました。私はExcelからのコピーを電子メールの本文に貼り付けると思う。

Sub Mail_Selection_Range_Outlook_Body() 
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
'Don't forget to copy the function RangetoHTML in the module. 
'Working in Excel 2000-2016 
    Dim rng As Range 
    Dim OutApp As Object 
    Dim OutMail As Object 

    Set rng = Nothing 
    On Error Resume Next 
    'Only the visible cells in the selection 
    Set rng = Selection.SpecialCells(xlCellTypeVisible) 
    'You can also use a fixed range if you want 
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible) 
    On Error GoTo 0 

    If rng 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") 
    Set OutMail = OutApp.CreateItem(0) 

    On Error Resume Next 
    With OutMail 
     .To = "[email protected]" 
     .CC = "" 
     .BCC = "" 
     .Subject = "This is the Subject line" 
     .HTMLBody = RangetoHTML(rng) 
     .Send 'or use .Display 
    End With 
    On Error GoTo 0 

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

    Set OutMail = Nothing 
    Set OutApp = Nothing 
End Sub 


Function RangetoHTML(rng As Range) 
' Changed by Ron de Bruin 28-Oct-2006 
' Working in Office 2000-2016 
    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) 
    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 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

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

出典

2017-10-24 03:46:51 ryguy72

VBA - シートをOutlookの電子メールにコピーする

答えて

関連する問題