Code not working..!!!

[balvinder]

Hi,

I've created one macro to send e-mails from excel automatically in picture format. (I have one Pre-defined format of e-mail in excel sheet which is getting copied & paste in lotus notes in image format, every-time when macro runs).

Problem: I'am not able to send e-mail. I know fault is somewhere in below code. With below mentioned entire code of program, I'am able to create new document & paste my e-mail template into body but not able to send e-mail & getting error:

Run Time Error 438
Object does't not support this property or method

Set Ballu = MailDoc.CreateRichTextItem("Body")
                With Ballu
                    Set Session = CreateObject("Notes.NotesUIWorkspace")
                    Set MailDoc = Session.editdocument(True, MailDoc, False)
                    Call MailDoc.GOTOFIELD("Body")
                    Worksheets("Range").Select
                    ActiveSheet.Range("A1:F44").Copy
                    Call MailDoc.Paste
                End With
                
    MailDoc.SaveMessageOnSend = True
    MailDoc.PostedDate = Now()
          On Error GoTo errorhandler1
    MailDoc.SEND 0, Recipient

When I remove below code, then I'am not getting any error & e-mails are saved in new document but not sent automatically.

MailDoc.SaveMessageOnSend = True
    MailDoc.PostedDate = Now()
          On Error GoTo errorhandler1
    MailDoc.SEND 0, Recipient

Please someone help me to clarify how to resolve this error. I guess error is occuring because I'am sending e-mail in image format instead of text.

Any suggestion would be highly appreciable..!!!

My Entire Code:

Sub NotsCoreCode()

Dim thisWB  As String
Dim newWB As String
Dim Pol_No As String
Dim Bank_Account_Number As String
Dim Transaction_Amount As String
Dim Bank_Name As String
Dim Email As String

    thisWB = ActiveWorkbook.Name
    
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
    Sheets("Data").Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
    End If
    
    Columns("A:A").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)
        
        If SupName <> "" Then
            
            Sheets("Data").Select
            Cells.Select
            
            ActiveSheet.Range("$A$1:$E$65000").AutoFilter Field:=1, Criteria1:="=" & SupName
            
            Columns("A:E").Select
            Range(Selection, Selection.End(xlUp)).Select
            Selection.Copy
            Sheets("Sheet5").Select
            Range("A1").Select
            ActiveSheet.Paste
            Cells.Select
            Cells.EntireColumn.AutoFit
            
            'Storing e-mail id into Email variable where email need to be sent
            Email = Range("E2").Value
            
            Range("A2:D2").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Range").Select
            Range("B23").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Range("A1").Select
        End If
            
  
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
  ' Declare Variables for  and macro setup

    Dim UserName As String
    Dim MailDbName As String
    Dim Maildb As Object
    Dim MailDoc As Object
    Dim AttachME As Object
    Dim Session As Object
    Dim EmbedObj1 As Object
    Dim t1 As Range
    Dim objNotesSession As Object
    Dim objNotesMailFile As Object
    Dim objNotesDocument As Object
    Dim objNotesField 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 = Email
    MailDoc.SendTo = Recipient
    MailDoc.Subject = "ECS Transaction Pre-Hit Intimation"
        Set Ballu = MailDoc.CreateRichTextItem("Body")
                With Ballu
                    Set Session = CreateObject("Notes.NotesUIWorkspace")
                    Set MailDoc = Session.editdocument(True, MailDoc, False)
                    Call MailDoc.GOTOFIELD("Body")
                    Worksheets("Range").Select
                    ActiveSheet.Range("A1:F44").Copy
                    Call MailDoc.Paste
                End With
                
    MailDoc.SaveMessageOnSend = True
    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
    
Next
            Sheets("tempsheet").Delete
            Sheets("Total Data").Select
    
            If ActiveSheet.AutoFilterMode Then
                Cells.Select
                ActiveSheet.ShowAllData
            End If

End Sub

[westconn1]

on which line does the error occur?
is it going into the error handler?
if need be disable the error handler to find which line the error occurs on

also your error handler should not be within the loop and should be after an exit sub, so that it does not run if no error occurs
you should not need to set all your objects to nothing within the loop as they will be reset on the next iteration

[balvinder]

Thanks for reply Westconn1

Error is occurring at below line:

MailDoc.SaveMessageOnSend = True

When i comment this line then error go to below line:

MailDoc.PostedDate = Now()

I'am using same lines for other macro's & there it's working fine. Here I'am trying to send e-mail in image format by copying range from excel but it's not working well. Everytime macro runs, e-mail gets copied in image format into new lotus notes e-mail document but mails are not going.

[westconn1]

Set Ballu = MailDoc.CreateRichTextItem("Body")
With Ballu
Set Session = CreateObject("Notes.NotesUIWorkspace")
Set MailDoc = Session.editdocument(True, MailDoc, False)
Call MailDoc.GOTOFIELD("Body")
Worksheets("Range").Select
ActiveSheet.Range("A1:F44").Copy
Call MailDoc.Paste
End With

MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()

within the ballu with block you are setting the maildoc item to an editdocument, maybe this is an issue, if the methods that error, are of a maildb.document object

[balvinder]

But i guess object issue is with the both below mentioned lines:

MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()

Since formatted mail is copied into lotus notes new document but while sending it is showing below error:

Run Time Error 438
Object does't not support this property or method.

I've tried other method also but in all other alternative codes also it is giving same error. For example in below link code it is giving error at below line:

http://www.rondebruin.nl/notes6.htm

'Save the created document.
   Call oUIDoc.Save(True, False, False)
   'If the e-mail also should be sent then add the following line.
   'Call oUIDoc.Send(True)

[balvinder]

Hi,

I've changed my entire code for lotus notes part & finally I've been able to bring different error message close to resolution. But mails are still not going.
I'am receiving below error message:

"Message could not be save or send, Please select information classification"

Post selecting information classification manually I'am able to send e-mail & can read in my inbox (since I'am sending to myself) clearly.

What I guess I'am missing information classification property only to send automated e-mail in image format. Please help to solve this error:

My entire code:

Public Function SendEMail()

Dim thisWB  As String
Dim newWB As String
Dim Email As String
Dim SendTo As String
Dim EmailSubject As String
Dim MyAttachment As String


    thisWB = ActiveWorkbook.Name
    
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
    Sheets("Data").Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
    End If
    
    Columns("A:A").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)
        
        If SupName <> "" Then
            
            Sheets("Data").Select
            Cells.Select
            
            ActiveSheet.Range("$A$1:$E$65000").AutoFilter Field:=1, Criteria1:="=" & SupName
            
            Columns("A:E").Select
            Range(Selection, Selection.End(xlUp)).Select
            Selection.Copy
            Sheets("Sheet5").Select
            Range("A1").Select
            ActiveSheet.Paste
            Cells.Select
            Cells.EntireColumn.AutoFit
            
            'Storing e-mail id into Email variable where email need to be sent
            Email = Range("E2").Value
            
            Range("A2:D2").Select
            Application.CutCopyMode = False
            Selection.Copy
            Sheets("Range").Select
            Range("B23").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Range("A1").Select
        End If
            
  
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   '********************************************************************************************
SendEMail = True

Dim myRange As Range   'I set a range on the spreadsheet
'Const EMBED_ATTACHMENT As Integer = 1454
'Const EMBED_OBJECT As Integer = 1453
'Const EMBED_OBJECTLINK As Integer = 1452

'Set E-mail format range
    Worksheets("Range").Activate
    Worksheets("Range").Range("A1:F44").Select
    Worksheets("Range").Range("A1:F44").Copy

On Error GoTo ErrorMsg
   
    Dim EmailList As Variant
    Dim ws, uidoc, session, db, uidb, NotesAttach, NotesDoc, objShell As Object
    Dim RichTextBody, RichTextAttachment As Object
    Dim server, mailfile, user, usersig As String
    Dim SubjectTxt, MsgTxt As String
           
    Set session = CreateObject("Notes.NotesSession")
    If session Is Nothing Then
        MsgBox "Sorry, unable to instantiate the Notes Session", vbOKOnly, "Unable to Continue"
        SendEMail = False
    End If
   
    user = session.UserName
    usersig = session.CommonUserName
    server = ""
    'server = session.GetEnvironmentString("MailServer", True)
    mailfile = session.GetEnvironmentString("MailFile", True)
   
    Set db = session.GetDatabase(server, mailfile)
    If Not db.IsOpen Then
        Call db.Open("", "")
        Exit Function
    End If
           
    If Not db.IsOpen Then
        MsgBox "Sorry, unable to open: " & mailfile, vbOK, "Unable to Continue"
        SendEMail = False
    End If
    
    Set NotesDoc = db.createdocument
    
    With NotesDoc
        .form = "Memo"
        .Subject = "ECS Transaction Pre-Hit Intimation" 'The subject line in the email
        .Principal = user
        .SendTo = Email  'e-mail ID variable to identify whom email need to be sent
    End With
    
    Set RichTextBody = NotesDoc.CreateRichTextItem("Body")
   
    With NotesDoc
        .computewithform False, False
        .SAVEMESSAGEONSEND = True
        .Save True, False, True
        
    End With
        
   'Now set the front end stuff
   Set ws = CreateObject("Notes.NotesUIWorkspace")
   If Not ws Is Nothing Then
   Set uidoc = ws.editdocument(True, NotesDoc)
   
    If Not uidoc Is Nothing Then
         If uidoc.editmode Then
           Call uidoc.gotofield("Body")
           Call uidoc.Paste
           'Call uidoc.Save
           'Call uidoc.Close
         End If
     End If
   End If
   
   With NotesDoc
        .postedDate = Date
        .Save True, False, True
        .SaveOptions = "0"
        '.IsSigned False
        .SEND False
   End With
   
   'close connection to free memory
    Set session = Nothing
    Set db = Nothing
    Set NotesAttach = Nothing
    Set NotesDoc = Nothing
    Set uidoc = Nothing
    Set ws = Nothing
    
ErrorMsg:
    SendEMail = False
    If Err.Number = 7225 Then
            MsgBox "The file " & Range("Fname_NZ_VaR") & " cannot be found in the location " & _
            Range("Path_NZ_VaR"), vbOKOnly, "Error"
    ElseIf Err.Number = 1004 Then
            MsgBox "One of the following may be causing an error:" & vbCrLf & _
            "1. The range 'Path_NZ_VaR' and/or 'Fname_NZ_VaR' does not exist in this spreadsheet," & _
            vbCrLf & "2. The range 'Fname_NZ_VaR' does not contain a filename," & vbCrLf _
            & "3. The path " & Range("Path_NZ_VaR") & " does not exist.", vbOKOnly, "Error"
    Else
            MsgBox Err.Number & Err.Description
    End If

'ErrorMsg:
'    On Error GoTo 0
'    SendEMail = False
'    MsgBox "Sorry there was an error processing the request: " + Error$ + "-" + Str(Err), vbOKOnly, "Error"
'    Set session = Nothing  'close connection to free memory
'    Set db = Nothing
'    Set NotesAttach = Nothing
'    Set NotesDoc = Nothing
'    Set ws = Nothing
'
Exit Function
   
   
   '********************************************************************************************
Next
            Sheets("tempsheet").Delete
            Sheets("Total Data").Select
    
            If ActiveSheet.AutoFilterMode Then
                Cells.Select
                ActiveSheet.ShowAllData
            End If
End Function

[balvinder]

hi,

I've found solution to this problem.

just added below lines in existing code & both problems resolved.

NotesDoc.Doc_Category = "Business Secret"

UIDOC.send
UIDOC.close

[westconn1]

pls mark thread resolved

[balvinder]

[balvinder]

Same has been resolved