Code is not working on other system

elsuji · Sep 2nd 2020

Dear Team,

I created code for sending reminder mail from excel through outlook. My code is

Code

Sub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String
Dim sht As Worksheet
Dim rng As Range
Dim sh As Worksheet


With Application

.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False

Set sht = Sheets("Master data")
Set sh = Sheets("Data")

Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
'Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)


On Error GoTo err_exit
With sht
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")

S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll

For i = 4 To lRow
If Cells(i, 5).Value <= 100 Or _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 Or _
.Cells(i, 20).Value >= 5 And .Cells(i, 20).Value <= 50 Or _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Or _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
Set OutMail = OutApp.CreateItem(0)

toList = .Cells(i, 24)

'CCList = Worksheets("Data").Cells(7, 3) & "; " & Worksheets("Data").Cells(8, 3) _
& "; " & Worksheets("Data").Cells(9, 3) & "; " & Worksheets("Data").Cells(10, 3) _
& "; " & Worksheets("Data").Cells(11, 3)


If .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine / Transmission / Axle & Hydraulic] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine / Transmission & Axle] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine / Transmission & Hydraulic] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine & Axle] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 And _
.Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine & Transmission] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission / Axle & Hydraulic] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission & Axle] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission & Hydraulic] Service"
ElseIf .Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 And _
.Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Axle & Hydraulic] Service"
ElseIf .Cells(i, 5).Value >= 5 And .Cells(i, 5).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Engine] Service"
ElseIf .Cells(i, 6).Value >= 5 And .Cells(i, 6).Value <= 100 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Transmission] Service"
ElseIf .Cells(i, 7).Value >= 5 And .Cells(i, 7).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Axle] Service"
ElseIf .Cells(i, 10).Value >= 5 And .Cells(i, 10).Value <= 250 Then
eSubject = "Reminder for your " & .Cells(i, 3) & " Machine [Hydraulic] Service"
End If


eBody = "<p style='font-family:Cambria;font-size: 12pt'>" & "Dear Sir, <br><br>" _
& "Greetings from " & "<b> SCHWING STETTER! </b><br><br>" _
& " We hope you're doing well.<br><br>" _
& " We wanted to inform you that your " & "<b>" & Cells(i, "C").Value & "</b>" _
& " Machine (Sr.No: " & "<b>" & Cells(i, "D") & "</b>" _
& ") reached " & "<b>" & .Cells(i, "T").Value & "</b>" & "hrs and due for next oil service.<br><br>" _
& " So kindly arrange the consumables as per the attachment.<br><br>" _
& " We truly care about your well-being, so if you have any questions or needs in advance of your appointment, you are welcome to call us anytime," & RangetoHTML(rng) & "<br><br>" & S & "</p>"

'Print '************************************************* ********
 'Turns off screen updating
 Application.ScreenUpdating = False
 'Makes a copy of the active sheet and save it to a temporary file
 Dim wks As Worksheet
 mySheet = Worksheets("Master data").Cells(i, "C").Value
 TempFilePath = Environ$("temp") & "\"
 'TempFileName = mySheet & "Service details.pdf"
 If .Cells(i, 5).Value <= 100 Then
 TempFileName = mySheet & " Engine Service Spares.pdf"
End If

FileFullPath = TempFilePath & TempFileName
 Set MR = Cells(i, "C")
 If .Cells(i, 5).Value <= 100 Then
 'mr.Interior.Color = VBA.ColorConstants.vbGreen
 Worksheets(mySheet).Range("B2:F46").ExportAsFixedFormat _
 Type:=xlTypePDF, _
 FileName:=FileFullPath, _
 Quality:=xlQualityStandard, _
 IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, _
 OpenAfterPublish:=False
 End If



On Error Resume Next

With OutMail
.To = toList
.CC = CCList
.BCC = ""
.Subject = eSubject
.HTMLBody = eBody
.display
.Attachments.Add FileFullPath
'.Send

End With

On Error GoTo 0
End If
Next i
End With

Set OutApp = Nothing

ActiveWorkbook.Save

err_exit:
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
'Sheets("Master data").Range("A1").Select

End Sub


Function RangetoHTML(rng As Range)
    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

Display More

This code is working perfectly and mails are triggering on my laptop. But when i am using my file to another laptop this code is not working.

Can any one please help me where is the mistake on this code

davesexcel · Sep 2nd 2020

Define what you mean by "Not Working"

elsuji · Sep 2nd 2020

i copied this excel file to another system and check the program running step by step. It is running till the bellow line

Code

Sub Remindermail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp As Object, _
OutMail As Object
Dim Signature As String
Dim sPath As String
Dim S As String
Dim sht As Worksheet
Dim rng As Range
Dim sh As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
Set sht = Sheets("Master data")
Set sh = Sheets("Data")
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
 MsgBox "An unknown error has occurred. "
 Exit Sub
End If
'Set rng = sh.Range("C2:D3").SpecialCells(xlCellTypeVisible)
On Error GoTo err_exit
With sht
lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
S = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(S, vbDirectory) <> vbNullString Then S = S & Dir$(S & "*.htm") Else S = ""
S = CreateObject("Scripting.FileSystemObject").GetFile(S).OpenAsTextStream(1, -2).ReadAll

Display More

and after that this program jumping directly to

Code

err_exit:
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
'Sheets("Master data").Range("A1").Select
End Sub

I am not understanding why it is happening another system only.

But in my system it is working properly.

davesexcel · Sep 2nd 2020

If you comment out the error trap, the code may show you what line the error occurs.

mycomputerguy-w · Sep 2nd 2020

Im wondering if this line may be the problem. if both systems don't have the same exact environment, this line will most likely break the procedure:

Code

S = Environ("appdata") & "\Microsoft\Signatures\"

elsuji · Sep 2nd 2020

I am also having the same doubt. How to rectify thisproblem

mycomputerguy-w · Sep 2nd 2020

comment out the line :

On Error GoTo err_exit

by using a ' in front of it. Run the code and tell us what the error is and which line errors out.

**royUK** · Sep 3rd 2020

This might help

Insert or change an Outlook signature using VBA

Code is not working on other system

Participate now!

Share