I Have a Macro made to help with building e-mails. It was Working just fine until I restarted my computer today. It still works on other computers but wont work with this one.
It will still make and e-mail, import the distro list.
But not the Attachments.
The body of the email does copy over to a new sheet but doesn't close out and looks like its trying to save and stops.
. Have to manually close it out
im at a loss on how to fix it
Here's the Code it it helps:
It will still make and e-mail, import the distro list.
But not the Attachments.
The body of the email does copy over to a new sheet but doesn't close out and looks like its trying to save and stops.
im at a loss on how to fix it
Here's the Code it it helps:
VBA Code:
Sub MakeOutlook()
'For Tips see: [URL]http://www.rondebruin.nl/win/winmail/Outlook/tips.htm[/URL]
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim EmailAddr1 As String
Dim EmailAddr2 As String
Dim Subj As String
Dim SigString As String
Dim Signature As String
Dim prompt As String
Dim R As Integer
Dim C As Integer
'from testing, outlook 2010 and 2007(?) require a different method to add attachments to emails in VBA
'use the method below for office 16.0
'project also requires a reference to microsoft outlook 16.0 object library when running on those systems
'Dim MyAttachments As OutMail.Attachments
Set rng = Nothing
'rng is the main body of the email to be created
Set rng = Range("A11:B62").SpecialCells(xlCellTypeVisible)
'checks that the range is valid
If rng Is Nothing Then
MsgBox "Error with range for email body", vbOKOnly
Exit Sub
End If
'pauses screen updating for faster processing
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'initiates creating email item
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'build list of email addresses
For Each cell In Worksheets(2).Columns("G").Cells
If cell.Value Like "*@*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
R = R + 1
End If
Next
prompt = "Creating Outlook item for " & R & " addresses"
'build list of CC addresses
For Each cell In Worksheets(2).Columns("H").Cells
If cell.Value Like "*@*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
C = C + 1
End If
Next
If C > 0 Then
prompt = prompt & " and " & C & " CC addresses"
End If
'subject line of email to be created
Subj = Range("A9").Value
'use this method for office 2016
'builds list of attachments
' Set MyAttachments = OutMail.Attachments
' For Each cell In Worksheets(2).Columns("I").Cells
' If cell.Value Like "*:\*" Then
' If Dir(cell.Value) <> "" Then
' MyAttachments.Add cell.Value
' prompt = prompt & vbCrLf & cell.Value & " " & FileDateTime(cell.Value)
' End If
' End If
' Next
'this section can be used to have your normal signature appear at the end of the email body
'this feature is not currently implemented
'assumes the sig file from outlook is stored in the default location
'Change only leam.htm to the name of your signature
' SigString = Environ("appdata") & "\Microsoft\Signatures\leam.htm"
' If Dir(SigString) <> "" Then
' Signature = GetBoiler(SigString)
' Else
' Signature = ""
' End If
On Error Resume Next
With OutMail
.to = EmailAddr1
.CC = EmailAddr2
.BCC = ""
.Subject = Subj
.HTMLBody = RangetoHTML(rng) & "<br>" & Signature
'.Attachments = MyAttachments
'.Send
'or use
'builds list of attachments
'use this method for office 2016
' Set MyAttachments = OutMail.Attachments
'use this attachment method for office 2010
'\/ \/ \/ disable this attachment method for outlook 2016 \/ \/ \/
For Each cell In Worksheets(2).Columns("I").Cells
If cell.Value Like "*:\*" Then
If Dir(cell.Value) <> "" Then
.Attachments.Add cell.Value
prompt = prompt & vbCrLf & cell.Value & " " & FileDateTime(cell.Value)
End If
End If
Next
'/\_/\_/\ disable this attachment method for outlook 2016 /\_/\_/\
prompt = prompt & vbCrLf & vbCrLf & "Do not forget to update gamma and temp."
'makes the message box for OK/Cancel Email
Dim Ret_type As Integer
Dim strMsg As String
strMsg = prompt
'Display MessageBox
Ret_type = MsgBox(strMsg, vbOKCancel + vbMsgBoxRight)
' Check pressed button in box
Select Case Ret_type
Case 1
.Display
Case 2
End Select
End With
'resumes screen updating
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
'releases outlook mail item
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'converts a range of cells into HTML for being pasted into the body of the email.
'this is typically the block of text that has a table of the values and whatnot
Function RangetoHTML(rng As Range) '
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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
'this section grabs the email signature (or other htm file) and returns a html string
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Last edited by a moderator:
