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:

Michael85

New Member
Joined
Dec 27, 2019
Messages
6
Office Version
  1. 365
Platform
  1. Windows
ok im not sure why but earlier today I installed a program for work. Once I uninstalled it the macro works fine.
IDK
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
20,151
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
As a matter of interest, what was the installed program that affected your macros ?
 

Watch MrExcel Video

Forum statistics

Threads
1,129,710
Messages
5,637,917
Members
416,992
Latest member
lo_

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
Top