Nos han cambiado las licencias de Office a Office 365. He revisado las macros y las que me fallan tienen que ver con las que envío correos automatizados. He podido arreglar todas, cambiando el código porque de Office 2013 a Office 365 cambia el código, se usa el objeto CDO.Message. Pero se me resiste esta macro, que envía un correo e incluye como parte del cuerpo del correo un rango de celdas donde hay un gráfico. Os pego el código para ver si me podéis ayudar. Después de la instrucción "ActiveWorkbook.EnvelopeVisible = True" el programa ya no ejecuta nada más. He probado con F8 paso a paso y ahí se detiene.
Necesito que el cuerpo del correo inserte las celdas A2:T49 de la hoja "Tablero".
Si veis que así no se me entiende puedo crear un archivo y pegar la macro, pero como el código no es muy largo lo he puesto así.
Sub EnviarTableroInsertado()
ApplicationOff
'variables
Dim iMsg As Object, iConf As Object
Dim cuerpo As String, schema As String, spie As String, mail As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message"): Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1
Set Flds = iConf.Fields
schema = "http://schemas.microsoft.com/cdo/configuration/"
With Flds
Flds.Item(schema & "sendusing") = 2
Flds.Item(schema & "smtpserver") = "smtp.office365.com"
Flds.Item(schema & "smtpserverport") = 25
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = "micorreo"
Flds.Item(schema & "sendpassword") = "micontraseña"
Flds.Item(schema & "smtpusessl") = True
Flds.Update
End With
Set tb = Sheets("Tablero")
tb.Select
mail = tb.Range("Y2")
tb.Range("A2:T49").Select
'
ActiveWorkbook.EnvelopeVisible = True
'
With iMsg
Set .Configuration = iConf
.From = "micorreo"
With ActiveSheet.MailEnvelope
.Item.Subject = "Produccion Tablero - Personal Propio I+M - " & tb.Range("M2")
.Item.To = mail
'.Item.CC = ""
'.Item.Introduction = "Adjuntamos Produccion Tablero - Personal Propio I+M -" & tb.Range("M2")
.Item.Send
End With
End With
Sheets("TOTAL").Select
Set iMsg = Nothing: Set iConf = Nothing: Set Flds = Nothing
Set tb = Nothing
'
ApplicationOn
End Sub
Gracias.
Moisés.
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
Hola a todos. De nuevo por aquí pidiendo ayuda.
Nos han cambiado las licencias de Office a Office 365. He revisado las macros y las que me fallan tienen que ver con las que envío correos automatizados. He podido arreglar todas, cambiando el código porque de Office 2013 a Office 365 cambia el código, se usa el objeto CDO.Message. Pero se me resiste esta macro, que envía un correo e incluye como parte del cuerpo del correo un rango de celdas donde hay un gráfico. Os pego el código para ver si me podéis ayudar. Después de la instrucción "ActiveWorkbook.EnvelopeVisible = True" el programa ya no ejecuta nada más. He probado con F8 paso a paso y ahí se detiene.
Necesito que el cuerpo del correo inserte las celdas A2:T49 de la hoja "Tablero".
Si veis que así no se me entiende puedo crear un archivo y pegar la macro, pero como el código no es muy largo lo he puesto así.
Sub EnviarTableroInsertado() ApplicationOff 'variables Dim iMsg As Object, iConf As Object Dim cuerpo As String, schema As String, spie As String, mail As String Dim Flds As Variant Set iMsg = CreateObject("CDO.Message"): Set iConf = CreateObject("CDO.Configuration") iConf.Load -1 Set Flds = iConf.Fields schema = "http://schemas.microsoft.com/cdo/configuration/" With Flds Flds.Item(schema & "sendusing") = 2 Flds.Item(schema & "smtpserver") = "smtp.office365.com" Flds.Item(schema & "smtpserverport") = 25 Flds.Item(schema & "smtpauthenticate") = 1 Flds.Item(schema & "sendusername") = "micorreo" Flds.Item(schema & "sendpassword") = "micontraseña" Flds.Item(schema & "smtpusessl") = True Flds.Update End With Set tb = Sheets("Tablero") tb.Select mail = tb.Range("Y2") tb.Range("A2:T49").Select ' ActiveWorkbook.EnvelopeVisible = True ' With iMsg Set .Configuration = iConf .From = "micorreo" With ActiveSheet.MailEnvelope .Item.Subject = "Produccion Tablero - Personal Propio I+M - " & tb.Range("M2") .Item.To = mail '.Item.CC = "" '.Item.Introduction = "Adjuntamos Produccion Tablero - Personal Propio I+M -" & tb.Range("M2") .Item.Send End With End With Sheets("TOTAL").Select Set iMsg = Nothing: Set iConf = Nothing: Set Flds = Nothing Set tb = Nothing ' ApplicationOn End Sub
Gracias.
Moisés.