Mohammad Shafaat
New Member
Hi team Any one help me out to rectified this need to change lotus mail converted into outlook how can we use this thru out look please help
Code:
vb code given below
Sub sendmail()
'
' sendmail Macro
'
Dim dte As Date
Dim mon As Integer
Dim yr As Integer
Dim mailcount As Integer
Dim filtercol As Integer
Dim Maildb As Object
Dim MailDoc As Object
Dim attachME As Object
Dim Session As Object
Dim EmbedObj1 As Object
Dim UserName As String
Dim MailDbName As String
Dim recipient As String
Dim ccRecipient As String
Dim bccRecipient As String
Dim subject As String
Dim finlsub As String
Dim stSignature As String
Dim addname As String
Dim bodytext As String
Dim Attachment1 As String
Dim Attachment2 As String
Dim FilName As String
Application.DisplayAlerts = False
dte = Date
mon = Month(dte)
yr = Year(dte)
Attachment2 = Range("F15").Value
Sheets("MAIL-ID").Activate
Range("AG2").Value = 0
mailcount = Range("AG14").Value
subject = Range("F2").Value
bodytext = Range("F6").Value & Chr(10) & Range("F7").Value & Chr(10) & Range("F8").Value & Chr(10) & Range("F9").Value & Chr(10) & Range("F10").Value & Chr(10)
addname = Range("F12").Value
If mon = 12 Then GoTo exitsub
exitsub: If UCase(Environ$("USERDOMAIN")) "ONEAIRTEL" Then MsgBox "This is not your copy of Filtermails " & Chr(10) & "You are an UNAUTHORISED USER ", vbCritical
Exit Sub
validated: If mailcount = 0 Then MsgBox "There are no recepients in your list.", vbCritical, "WHAT ARE YOU DOING?"
For x = 0 To (mailcount - 1)
Sheets("MAIL-ID").Select
Range("AG2").Value = x + 1
FilName = (Environ$("temp")) & "\temp.xls"
If Dir(FilName) "" Then
Kill FilName
End If
filtercol = Range("F4").Value
Range("AG4").Select
Selection.Copy
Range("AG7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
recipient = Range("AG7").Value
Range("AG5").Select
Selection.Copy
Range("AG8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ccRecipient = Range("AG8").Value
If ccRecipient = "0" Then
ccRecipient = ""
End If
Range("AG6").Select
Selection.Copy
Range("AG9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
bccRecipient = Range("AG9").Value
If bccRecipient = "0" Then
bccRecipient = ""
End If
Range("AG3").Select
Selection.Copy
Range("AG11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("AG11").Copy (Sheets("DATA").Range("O60000"))
Sheets("DATA").Select
If addname = "YES" Then
finlsub = subject & " ( " & Range("O60000").Value & " )"
finlbody = "Dear " & Range("O60000").Value & Chr(10) & Chr(10) & bodytext
End If
If addname = "NO" Then
finlsub = subject
finlbody = bodytext
End If
Range("A1").Select
If Range("a1") = "" Then
MsgBox "NO or Wrong arrangement of Data in DATA Sheet", vbCritical
Exit For
End If
Selection.AutoFilter
Selection.AutoFilter field:=filtercol, Criteria1:= _
Range("O60000").Value
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWorkbook.SaveAs Filename:=FilName, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close
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
On Error Resume Next
Maildb.OPENMAIL
End If
Set MailDoc = Maildb.CreateDocument
MailDoc.form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile") _
.GetItemValue("Signature")(0)
With MailDoc
.SendTo = recipient
.copyto = ccRecipient
.blindcopyto = bccRecipient
.subject = finlsub
.body = finlbody & vbCrLf & vbCrLf & stSignature
End With
MailDoc.SaveMessageOnSend = True
Attachment1 = FilName
If Attachment1 "" Then
Set attachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
Set EmbedObj1 = attachME.EmbedObject(1454, "", Attachment1, "Attachment")
Set EmbedObj2 = attachME.EmbedObject(1454, "", Attachment2, "Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If
MailDoc.PostedDate = Now()
MailDoc.send 0, recipient
Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set Session = Nothing
Set EmbedObj1 = Nothing
finlsub = Null
finlbody = Null
Next
Sheets("MAIL-ID").Activate
Range("A1").Select
MsgBox "Thank you for using this MACRO"
End Sub
Last edited by a moderator:
