ERROR 3000 al enviar correo con HCL NOTES y EXCEL VBA
Publicado por Eduardol (1 intervención) el 12/01/2023 21:10:32
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.
Espero que puedan ayudarme.
GRACIAS!!
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 NextSet a = ThisWorkbook.Sheets("Base Emails")Call bucleAtravesdeArchivosEnCarpetapf = 4 'Primera FilaUf = 0Do While Uf = 0cuit = 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 1Else
Uf = 1Exit Do
End If
Loop
VbMessage = "Mensajes Enviados"
Call Borrado
End Sub
Espero que puedan ayudarme.
GRACIAS!!
Valora esta pregunta
0