Stopped working on personal Computer

Michael85

New Member
Joined
Dec 27, 2019
Messages
6
Office Version
  1. 365
Platform
  1. Windows
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.
1577479188358.png
. Have to manually close it out

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:

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
please use the VBA code tags so your code doesn't start sprouting emoji's
[CODE=vba][/CODE]

does your code shoot back any error messages?
have you run through the code with F8 in the developer screen? if not try doing that seeing the values of the attachments
there seems to be some notes for attachments regarding methods for 2016, 2018, etc and i see on your profile office 365 - so which are you actually using?
 
Upvote 0
also
Code:
'Dim MyAttachments As OutMail.Attachments
is commented out

another suggestion is making sure your references are unchanged
 
Upvote 0
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:
Upvote 0
please use the VBA code tags so your code doesn't start sprouting emoji's
[CODE=vba][/CODE]

does your code shoot back any error messages?
have you run through the code with F8 in the developer screen? if not try doing that seeing the values of the attachments
there seems to be some notes for attachments regarding methods for 2016, 2018, etc and i see on your profile office 365 - so which are you actually using?


Not sure how to Do that.

And using F8 it seams to loop
1577481425522.png


Never did that before I don't think
 
Upvote 0
I believe im Using Office 365. That what it say in file and accounts

okay well first try changing
VBA Code:
'Dim MyAttachments As OutMail.Attachments
to
Code:
Dim MyAttachments As OutMail.Attachments

anything that is commented out (in green) that mentions that it should be commented in for 2016
anything that is not commented out that indicates it should be if using 2016 excel should be commented out by adding '
other than that the code is very all over the place and hard to see, but you're most likely getting your attachment left out because you're using office 365 vs other computers you try are probably using 2010/2007
 
Upvote 0
okay well first try changing
VBA Code:
'Dim MyAttachments As OutMail.Attachments
to
Code:
Dim MyAttachments As OutMail.Attachments

anything that is commented out (in green) that mentions that it should be commented in for 2016
anything that is not commented out that indicates it should be if using 2016 excel should be commented out by adding '
other than that the code is very all over the place and hard to see, but you're most likely getting your attachment left out because you're using office 365 vs other computers you try are probably using 2010/2007


When I try that I get
1577484535877.png
 
Upvote 0
Not getting involved in the solution, but to wrap your code in code tags, simply highlight the code and press the <vba/> button on the toolbar
 
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,286
Members
452,631
Latest member
a_potato

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top