hi team,
I have the below code to send emails and gives an error (Run time error 2147467259 (80004005) outlook does not recognise one or more names) when I try to run.
Please help me to resolve this issue.
I have the below code to send emails and gives an error (Run time error 2147467259 (80004005) outlook does not recognise one or more names) when I try to run.
Please help me to resolve this issue.
Code:
Sub SendAMail_Click()
Application.ScreenUpdating = False
Dim BottomA As Long
BottomA = Sheets("TOBESENT").Range("A" & Rows.Count).End(xlUp).Row
Dim x As Long
x = 0
Dim Director As Range
Dim findDir As Range
Dim ws As Worksheet
Dim olapp As Outlook.Application
Dim olmail As Outlook.MailItem
Dim rng1 As Range
Dim rng2 As Range
Dim StrBody1 As String
Dim StrBody2 As String
Dim StrBody3 As String
Dim LResult As String
Dim i As Long
Dim SigString As String
Dim Signature As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
Sheets("TOBESENT").Range("A1:A" & BottomA).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range _
("A1:A" & BottomA), Unique:=True
Set rnguniques = Sheets("TOBESENT").Range("A2:A" & BottomA).SpecialCells(xlCellTypeVisible)
If Sheets("TOBESENT").FilterMode Then Sheets("TOBESENT").ShowAllData
For Each Director In rnguniques
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(Director.Value)
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "New"
Set rng1 = Sheets("TOBESENT").Range("A1:J1").SpecialCells(xlCellTypeVisible)
rng1.Copy
Sheets("New").Range("A1").PasteSpecial Paste:=xlPasteValues
For Each findDir In Sheets("TOBESENT").Range("A1:A" & BottomA)
If findDir = Director Then
x = x + 1
findDir.EntireRow.Copy ActiveSheet.Cells(x + 1, "A")
End If
Next findDir
Worksheets("New").Columns("B:B").Select
Worksheets("New").Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("New").Range("K1"), Unique:=True
' Worksheets("New").Range("K1").Select
' Selection.Clear
Worksheets("New").Range("L1").Formula = "=CONCATENATE(R[1]C[-1],""; "",R[2]C[-1],""; "",R[3]C[-1],""; "",R[4]C[-1],""; "",R[5]C[-1],""; "",R[6]C[-1],""; "",R[7]C[-1],""; "",R[8]C[-1],""; "",R[9]C[-1],""; "",R[10]C[-1],""; "",R[11]C[-1],""; "",R[12]C[-1],""; "",R[13]C[-1],""; "",R[14]C[-1])"
Worksheets("New").Range("M1").Formula = "=CONCATENATE(R[1]C[-10],""; "",R[2]C[-10],""; "",R[3]C[-10],""; "",R[4]C[-10],""; "",R[5]C[-10],""; "",R[6]C[-10],""; "",R[7]C[-10],""; "",R[8]C[-10],""; "",R[9]C[-10],""; "",R[10]C[-10],""; "",R[11]C[-10],""; "",R[12]C[-10],""; "",R[13]C[-10],""; "",R[14]C[-10],""; "",R[15]C[-10],""; "",R[16]C[-10],""; "",R[17]C[-10],""; "",R[18]C[-10],""; "",R[19]C[-10],""; "",R[20]C[-10],""; "",R[21]C[-10],""; "",R[22]C[-10],""; "",R[23]C[-10],""; "",R[24]C[-10],""; "",R[25]C[-10],""; "",R[26]C[-10],""; "",R[27]C[-10],""; "",R[28]C[-10],""; "",R[29]C[-10],""; "",R[30]C[-10],""; "",R[31]C[-10],""; "",R[32]C[-10],""; "",R[33]C[-10],,""; "",R[34]C[-10])"
Worksheets("New").Range("L1:M1").Copy
Worksheets("New").Range("L1:M1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
x = 0
Worksheets("New").Range("B1").Select
Set olapp = New Outlook.Application
Set olmail = olapp.CreateItem(olMailItem)
' SigString = Environ("appdata") & _
' "\Microsoft\Signatures\Latha.htm"
'
' If Dir(SigString) <> "" Then
' Signature = GetBoiler(SigString)
' Else
' Signature = ""
' End If
On Error GoTo 0
With olmail
.SentOnBehalfOfName = "servicedesk@altisource.com"
.To = Sheets("New").Range("M1").Value
.CC = Sheets("New").Range("A2").Value & Sheets("New").Range("L1").Value
'Specific email Ids can be added like this
'"Vikram.Poovanna@altisource.com;" & "Sunil.Kumar2@altisource.com;" & "Gaurav.Kansal@altisource.com"
.Subject = "IMPORTANT: Password Reset - Registration"
'with subject the cell value can be added like this "Ageing and Open Tickets Follow Up <" & Cells(i, 3).Value & ">"
'Set body format to HTML
StrBody1 = "<P STYLE='font-family:Calibri ;font-size:15'>Addressed" & "<p>"
StrBody2 = "<P STYLE='font-family:Calibri ;font-size:15'>We have found your name in the list of non-registered users in self-service password reset (SSPR) portal. Registering to this portal is mandatory." & "<br><br>" & "In future, we require each and every employee to reset their network password on their own without calling Service Desk." & "<br><br>" & _
"<P STYLE='font-family:Calibri ;font-size:15'>We need you to get yourself and your team members (if any) registered into Password Reset portal as soon as possible." & "<p>"
StrBody3 = "<P STYLE='font-family:Calibri ;font-size:15'> For registering, refer to the attached guide. You can also refer to " & "<a href=""http://nav8apspnp01/sites/IT/tts/SitePages/Home.aspx"">Self-Service Password Reset - End User Support Documentation" & "</a>" & " for details."
' font style or size can be added like this "<P STYLE='font-family:Trebuchet MS (10) ;font-size:13'> Refer to "
StrBody4 = "<P STYLE='font-family:Calibri ;font-size:15'> for details."
StrBody5 = "<P STYLE='font-family:Calibri ;font-size:15'>Technology Service Desk" & "<br>" & "<br>" & "<P STYLE='font-family:Trebuchet MS (10) ;font-size:13'>For faster service, you may use the Self Service tool to submit your ticket at " & "<a href=""https://servicedesk.ascorp.com/CAisd/pdmweb.exe"">http://servicedesk.ascorp.com" & "</a>"
.HTMLBody = StrBody1 & StrBody2 & StrBody3 & "<br>" & "<br>" & "<br>" & "<br>" & StrBody5
'.Attachments.Add TempFilePath & TempFileName & FileExtStr
'.Attachments.Add ("\\bpk8fsasnp01\Commonshare3\ITOperation\Password Reset - Do It Yourself!.msg")
'.Attachments.Add ("\\bpk8fsasnp01\Commonshare3\ITOperation\SSPR -EndUser - SupportDoc - ASPS.pdf")
.Attachments.Add ("C:\Users\dlatha\Desktop\Password Reset Guide.PDF")
.Send
End With
On Error GoTo 0
Application.DisplayAlerts = False
Sheets("New").Delete
Application.DisplayAlerts = True
ThisWorkbook.Save
'End With
Next
End Sub
