在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