Outlook会議で特定のExcel範囲を貼り付けます

Question

Excelからマクロを実行して特定の範囲を会議招待状にコピー＆ペーストしようとしています。 Ron de Bruinのコードを編集しようとしました。

Sub Mail_Selection_Range_Outlook_Body() 
'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 = True 
     .ScreenUpdating = False 
    End With 

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

    On Error Resume Next 
    With OutMail 
     .To = "bob@bob.com" 
     .CC = "" 
     .BCC = "" 
     .Subject = "This is the Subject line" 
     .HTMLBody = RangetoHTML(rng) 
     .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 

私は

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

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

に会議を変更するときにはうまく動作しますが、は開きますが、貼り付けます範囲は来ていない招待します。

あなたが提供できるヘルプは、人生の節約になります。

Answer 1

Public Sub Meeting_Invites() 

Dim UsrName As String, Docpath As String 
Dim Rpt As String 
Dim openpath As String, NameVal As String 
Dim PDFPath As String 
Dim olApp As Outlook.Application 
Set olApp = Outlook.Application 
Dim exclapp As Excel.Application 
Set exclapp = Excel.Application 
Set ObjMail = olApp.CreateItem(olMailItem) 

Dim Mymail As Outlook.AppointmentItem 

UsrName = Environ("USERNAME") 

Application.ScreenUpdating = False 

If olApp.Session.Offline = False Then 

    MsgBox "Please go offline, before running the macro to generate mails" 
    Exit Sub 

    Else 

End If 

ThisWorkbook.Sheets("Welcome").Select 

Range("A1").Select 

DataCount = ActiveSheet.Cells(Application.Rows.Count, 1).End(xlUp).Row 

On Error GoTo ExitPlace: 

For a = 2 To DataCount 

    ActiveSheet.Cells(1, 30) = a 
    ActiveSheet.Calculate 

    ActiveSheet.Range("Ac3:Ad26").Copy 

    'Set rng1 = ActiveSheet.Range("Ac3:Ad26") 

    Set Mymail = olApp.CreateItem(olAppointmentItem) 

    Mymail.Display 

    Dim objItem As Object 
    Dim objInsp As Outlook.Inspector 
    Dim objWord As Word.Application 
    Dim objDoc As Word.Document 
    Dim objSel As Word.Selection 

    Set objItem = Mymail 
    Set objInsp = objItem.GetInspector 
    Set objDoc = objInsp.WordEditor 
    Set objWord = objDoc.Application 
    Set objSel = objWord.Selection 

    objSel.PasteAndFormat (wdFormatOriginalFormatting) 

    Set Rng = Sheets("Welcome").Cells 

    If Rng(a, 3).Value <> "" Then 
     With Mymail 
      .Attachments.Add ThisWorkbook.Path & "\" & Rng(j, 3).Value 

     End With 
    End If 

    If Rng(a, 4).Value <> "" Then 
     With Mymail 
      .Attachments.Add ThisWorkbook.Path & "\" & Rng(j, 4).Value 
     End With 
    End If 

    If Rng(a, 5).Value <> "" Then 
     With Mymail 
      .Attachments.Add ThisWorkbook.Path & "\" & Rng(j, 5).Value 
     End With 
    End If 

    With Mymail 
      .Recipients.Add Rng(a, 1).Value 
      '.SentOnBehalfOfName = Rng(a, 2).Value 
      .Subject = Rng(a, 6).Value 
      .Location = Rng(a, 7).Value 
      .Start = Rng(a, 8).Value 
      .Duration = 90 
      .MeetingStatus = olMeeting 
      '.Send 
      '.Close (olSave) 

    End With 

    Set objItem = Nothing 
    Set objInsp = Nothing 
    Set objDoc = Nothing 
    Set objWord = Nothing 
    Set objSel = Nothing 
    Application.CutCopyMode = False 

Next 

On Error GoTo 0 

Set Mymail = Nothing 
Set exclapp = Nothing 
Set olApp = Nothing 

ActiveWorkbook.Sheets("Welcome").Select 
Range("A1").Select 

MsgBox "Dear " & UsrName & ":" & " Please check the Calendar Space for Meeting Invites" 

Exit Sub 

ExitPlace: 
    If Err.Number = 4605 Then 
     MsgBox "Error Pasting the Mail content to the Meeting body, Please contact Developer or Try Running the Macro Again." 
     Mymail.Close (olDiscard) 

Else 

    MsgBox "The process got some error at row " & a & " Please check and run again" 
    Resume 
    Mymail.Close (olDiscard) 
End If 

' Resume 

End Sub