Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Visual Basic » Error 3000, Enviar Correo con EXCEL VBA y HCL NOTES

Visual Basic - Error 3000, Enviar Correo con EXCEL VBA y HCL NOTES

Life is soft - evento anual de software empresarial
Volver
Nuevo Tema
<<>>
 
Vista:
sin imagen de perfil

Error 3000, Enviar Correo con EXCEL VBA y HCL NOTES

Publicado por Eduardol (10 intervenciones) el 12/01/2023 21:09:08
Hola.

Hice un codigo para enviar unos mails, utilizando HCL NOTES y Excel. Me ha costado trabajo y he utilizado CHATGTP, para implementar algunas soluciones a algunos problemas que me aparecieron, pero me he quedado atascado.
El ERROR 3000, aparece al recorrer la linea ".SEND 0, vaRecipient". Creo que lo que sucede es que se pierde la coneccion con la base de datos, despues de recorrer el procedimiento de adjuntar una imagen al cuerpo del correo. Ya que si elimino esas lineas del codigo, no surge ningun error.


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
Sub SendQuoteToEmail()
    Dim NSession As Object
    Dim NDatabase As Object
    Dim NUIWorkSpace As Object
    Dim NDoc As Object
    Dim NUIdoc As Object
    Dim NRichTextItem As Object
    Dim NrichTextHeader As Object
    Dim NMimeImage As Object
    Dim strImageType As String
    Dim WordApp As Object
    Dim EmbedObj As Object
    Dim Body As Object
    Dim NStream As Object
    Dim Subject As String
    Dim MailAddress As String
    Dim MailAddressCC As String
    Dim MailAddressCC2 As String
    Dim MailAddressCCO As String
    Dim MailAddressCCO2 As String
    Dim ArchivoAdjunto1, ArchivoAdjunto2, ArchivoAdjunto3, ArchivoAdjunto4 As String
    Dim ImagenAdjunta As String
    Dim pf As Integer
    Dim Uf As Integer
    Dim x As Double
    'On Error Resume Next
 
Set a = ThisWorkbook.Sheets("Base Emails")
Call bucleAtravesdeArchivosEnCarpeta
 
pf = 4 'Primera Fila
Uf = 0
Do While Uf = 0
 
    cuit = Range("a" & pf).Value
        If cuit <> Empty Then
            Subject = UserForm1.SubjectBox & a.Cells(pf, "D") & " - CUIL N°: " & a.Cells(pf, "A") ' ver como hacer para dar formato al N° CUIL
            MailAddress = a.Cells(pf, "F") 'el valor es dinamico, corresponde al array de la columna F
            MailAddressCC = UserForm1.TextBoxCC
            MailAddressCC2 = UserForm1.TextBoxCC2
            MailAddressCCO = UserForm1.TextBoxCCO
            MailAddressCCO2 = UserForm1.TextBoxCCO2
 
            Set NSession = CreateObject("Notes.NotesSession")
 
            Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
            Set NDatabase = NSession.GETDATABASE("", "")
 
        If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
 
            Set NDoc = NDatabase.CREATEDOCUMENT
            With NDoc
                .SendTo = MailAddress
                .CopyTo = MailAddressCC & ", " & MailAddressCC2
                .Subject = Subject
                .Body = UserForm1.PrimeraLineaBox & vbLf & vbLf & _
                        UserForm1.PrimerParrafoBox & vbLf & vbLf & _
                        UserForm1.SegundoParrafoBox & vbLf & vbLf & _
                        UserForm1.TercerParrafoBox & vbLf
                .SAVEMESSAGEONSEND = True
 
            End With
 
' Aqui se adjunta una imagen al cuerpo del correo.
            ImagenAdjunta = ThisWorkbook.Path & "\Imagenes\" & Worksheets("Archivos").Range("A" & 5)
                If ImagenAdjunta <> "" Then
                    Set NStream = NSession.CREATESTREAM
                    Call NStream.Open(ImagenAdjunta)
                    Set Body = NDoc.CreateMIMEEntity("memo")
                    Set richTextHeader = Body.CreateHeader("Content-Type")
                    Call richTextHeader.SetHeaderVal("multipart/mixed")
                    Set mimeImage = Body.CreateChildEntity()
                    strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" - ver como se escribe esta mierda
                    Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
                    Call NStream.Close
                End If
 
            'Ahora Adjuntamos los Archivos guardado en la carpeta "Archivos", que se encuentran listado en la Hoja "Archivos".
            ArchivoAdjunto1 = ThisWorkbook.Path & "\Archivos\" & Worksheets("Archivos").Range("A" & 1)
                If ArchivoAdjunto1 <> "" Then
                    Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment1")
                    Set EmbedObj = AttachMe.EmbedObject(1454, "", ArchivoAdjunto1, "Adjunto")
                End If
 
            ArchivoAdjunto2 = ThisWorkbook.Path & "\Archivos\" & Worksheets("Archivos").Range("A" & 2)
                If ArchivoAdjunto2 <> "" Then
                    Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment2")
                    Set EmbedObj = AttachMe.EmbedObject(1454, "", ArchivoAdjunto2, "Adjunto")
                End If
 
            ArchivoAdjunto3 = ThisWorkbook.Path & "\Archivos\" & Worksheets("Archivos").Range("A" & 3)
                If ArchivoAdjunto3 <> "" Then
                    Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment3")
                    Set EmbedObj = AttachMe.EmbedObject(1454, "", ArchivoAdjunto3, "Adjunto")
                End If
 
            ArchivoAdjunto4 = ThisWorkbook.Path & "\Archivos\" & Worksheets("Archivos").Range("A" & 4)
                    If ArchivoAdjunto4 <> "" Then
                    Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment4")
                    Set EmbedObj = AttachMe.EmbedObject(1454, "", ArchivoAdjunto4, "Adjunto")
                End If
 
            With NDoc
            .PostedDate = Now()
            .SEND 0, vaRecipient  '<--- ERROR 3000
 
            End With
            Set NStream = Nothing
            Set NDoc = Nothing
            Set WordApp = Nothing
            Set NSession = Nothing
            Set EmbedObj = Nothing
 
            pf = pf + 1
            'pausa 1
        Else
            Uf = 1
            Exit Do
        End If
Loop
VbMessage = "Mensajes Enviados"
Call Borrado
End Sub

Espero que puedan ayudarme.

GRACIAS!!
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder