我正在尝试从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)
会议邀请会打开，但粘贴的范围不会过来。
您可以提供的任何帮助都可以节省生命。
答案 0 :(得分：0)
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