Hi,
I've been able to send e-mails using lotus notes after lot of macro munching in excel but without attachment. I'am using below code to add attachment. Please somebody tell me error in this code.
In this code i want to add specific agent excel workbook into lotus notes for which file name is stored in Sheet2 A3 cell.
I simply want to search & attach sheet2 stored value from given path
D:\Agent Data Sheets\ "Sheet2.A3 Cell".xls (Red part is file name which need to be picked up from Sheet2 A3 cell)
My entire code:
I've been able to send e-mails using lotus notes after lot of macro munching in excel but without attachment. I'am using below code to add attachment. Please somebody tell me error in this code.
Code:
attachment1 = "D:\Agent Data Sheets\" & Sheet2.Range("A3") & ".XLS"In this code i want to add specific agent excel workbook into lotus notes for which file name is stored in Sheet2 A3 cell.
I simply want to search & attach sheet2 stored value from given path
D:\Agent Data Sheets\ "Sheet2.A3 Cell".xls (Red part is file name which need to be picked up from Sheet2 A3 cell)
My entire code:
Code:
Sub details()
Dim thisWB As String
Dim newWB As String
Dim Email As String
Dim AgentID As String
thisWB = ActiveWorkbook.Name
On Error Resume Next
Sheets("tempsheet").Delete
On Error GoTo 0
Sheets.Add
ActiveSheet.Name = "tempsheet"
Sheets("Total Data").Select
If Range("A2") <> "" Then
Email = Range("A2").Value
On Error Resume Next
End If
If ActiveSheet.AutoFilterMode Then
Cells.Select
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End If
Columns("R:R").Select
Selection.Copy
Sheets("tempsheet").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
If (Cells(1, 1) = "") Then
lastrow = Cells(1, 1).End(xlDown).Row
If lastrow <> Rows.Count Then
Range("A1:A" & lastrow - 1).Select
Selection.Delete Shift:=xlUp
End If
End If
Columns("A:A").Select
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
Columns("A:A").Delete
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
For suppno = 2 To lMaxSupp
Windows(thisWB).Activate
supName = Sheets("tempsheet").Range("A" & suppno)
AgentID = supName
If supName <> "" Then
Workbooks.Add
ActiveWorkbook.SaveAs supName, FileFormat:=56
newWB = ActiveWorkbook.Name
Windows(thisWB).Activate
Sheets("Total Data").Select
Cells.Select
If ActiveSheet.AutoFilterMode = False Then
Selection.AutoFilter
End If
Selection.AutoFilter Field:=18, Criteria1:="=" & supName, Operator:=xlAnd, Criteria2:="<>"
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Rows("1:" & lastrow).Copy
Windows(newWB).Activate
ActiveSheet.Paste
Selection.AutoFilter
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
If Range("A2") <> "" Then
Email = Range("A2").Value
On Error Resume Next
End If
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:="Sheet1!A1:AM65000").CreatePivotTable TableDestination:="", TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("STATUS")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("PLAN_ID")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables("PivotTable1").PivotFields("PLAN_ID"), "Count of PLAN_ID", xlCount
ActiveSheet.PivotTables("PivotTable1").PivotFields("Count of PLAN_ID").Caption = "Count"
ActiveSheet.PivotTables("PivotTable1").PivotFields("STATUS").AutoSort xlDescending, "Count"
ActiveSheet.PivotTables("PivotTable1").CompactLayoutRowHeader = "Policy Status"
With ActiveSheet.PivotTables("PivotTable1").PivotFields("STATUS")
.PivotItems("(blank)").Visible = False
End With
Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:="Sheet1!A1:AM65000").CreatePivotTable TableDestination:=Worksheets("Sheet4").Range("D3"), TableName:="PivotTable2", DefaultVersion:=xlPivotTableVersion10
With ActiveSheet.PivotTables("PivotTable2").PivotFields("Registration Status")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable2").AddDataField ActiveSheet.PivotTables("PivotTable2").PivotFields("PLAN_ID"), "Count of PLAN_ID", xlCount
ActiveSheet.PivotTables("PivotTable2").PivotFields("Count of PLAN_ID").Caption = "Count"
Range("D2").Select
ActiveCell.FormulaR1C1 = "* Blank represents that ECS Mandate has not received at Mandate desk till date"
Range("D2").Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Range("D1").Select
Selection.End(xlToLeft).Select
Range("A4").Select
Range("A3:B3").Select
Range(Selection, Selection.End(xlDown)).Select
Range("A1").Select
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Total Data"
Sheets("Sheet4").Select
Sheets("Sheet4").Name = "Summary of Policies"
Sheets("Sheet2").Select
Range("A2") = Email
Range("A3") = AgentID
ActiveWorkbook.Save
' E-mail Agent data sheet to Agent -------------------------------
Dim Session As Object
Dim EmbedObj1 As Object
' Open and locate current LOTUS NOTES User
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
' Select range of e-mail addresses
Recipient = Sheets("Sheet2").Range("A2").Value ' - Retrieving Agent E-mail ID from Cell Value
MailDoc.SendTo = Recipient
' ---------- CC Mail part ----------------------
'ans = MsgBox("Would you like to Copy (cc) anyone on this message?" , vbQuestion & vbYesNo, "Send Copy")
'If ans = vbYes Then
'ccRecipient = InputBox("Please enter the additional recipient's e-mail address", "Input e-mail address")
'MailDoc.CopyTo = ccRecipient
'End If
' ----------------------------------------------
MailDoc.Subject = "ECS Data For Your Customers - MAX NEW YORK LIFE INSURANCE"
MailDoc.Body = "Dear Agent, Greetings from Max New York Life Insurance Company. Please find attached data for your ECS customers with latest status"
' Select Workbook to Attach to E-Mail
MailDoc.SaveMessageOnSend = True
attachment1 = "D:\Agent Data Sheets\" & Sheet2.Range("A3") & ".XLS" 'Required File Name
If attachment1 <> "" Then
On Error Resume Next
Set AttachME = MailDoc.CREATERICHTEXTITEM("attachment1")
Set EmbedObj1 = AttachME.embedobject(1454, "attachment1", "D:\Agent Data Sheets\" & Sheet2.Range("A3") & ".XLS", "") 'Required File Name
On Error Resume Next
End If
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.Send 0, Recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End If
ActiveWorkbook.Close
Next
Sheets("tempsheet").Delete
Sheets("Total Data").Select
If ActiveSheet.AutoFilterMode Then
Cells.Select
ActiveSheet.ShowAllData
End If
End Sub
