Ver originales (Francés)

Envío de una selección de celdas por correo electrónico - Page 2

Anterior
  • 1
  • 2
  1. Mike-31 Mensajes publicados 18205 Fecha de registro   Estado Colaborador Última intervención   5 147
     
    Hola,

    ¿qué quieres decir con maquetación, el ancho de las columnas
    la altura de la línea
    la coloración de ciertas celdas o de la fuente

    --
    Nos vemos
    Mike-31

    Un periodo de fracaso es un momento soñado para sembrar las semillas del saber.
    0
  2. maya
     
    re
    quiero decir con ello: guarda todo excepto los anchos de columna
    @+ gracias
    0
  3. Mike-31 Mensajes publicados 18205 Fecha de registro   Estado Colaborador Última intervención   5 147
     
    Hola,

    pega este código en lugar del otro, no olvides completar las constantes
    Const Dest As Variant
    Const Exped As Variant
    Const C_Ent As Variant
    y la de si el rango a copiar ha cambiado
    Const Plage As Variant

    Sub Envoi_Mail ()

    Dim cdoBasic
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb, Destwb As Workbook
    Dim TempFilePath, TempFileName As String
    Dim Wb, iMsg, iConf As Object
    Dim Flds As Variant
    '--------------------------- Constante a completar
    Const Feuille As Variant = "FORMULAIRE" '------------- nombre de la hoja a copiar
    Const Plage As Variant = "A1:H10" '------------------- rango a copiar, (Cell.Copy toda la hoja)
    Const Dest As Variant = "wwwwwwwwwww@free.fr" '- correo del destinatario
    Const Exped As Variant = "www.xxxxxxx@free.fr" '------ correo de respuesta del remitente
    Const C_Ent As Variant = "SMTP.free.fr" '------------- dirección del SMTP (correo entrante)
    Const CC As Variant = "" '---------------------------- correo CC
    Const BCC As Variant = "" '--------------------------- correo destinatario para envío BCC o BCI o CCI
    Const NumPort As Variant = 25 '----------------------- número de puerto del servidor saliente
    Const Nom_envoi As Variant = "Sourcewb.Name" '----------- nombre identico del archivo enviado o reemplazar por "Nombre deseado"
    '--------------------------- Si la conexión requiere una autenticación
    Const N_Messag As Variant = "False" '----------------- Nombre de usuario del correo, si no, poner "False"
    Const Pass As Variant = "False" '--------------------- contraseña si no, poner False
    '--------------------------- Conexión SSL como Gmail y Hotmail etc... poner la constante a "True" o "False"
    Const Typ_Conex As Variant = "False"

    '--------------------------- Inicio del procedimiento
    On Error GoTo errorHandler
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    End With
    Set Sourcewb = ActiveWorkbook
    Set Destwb = Workbooks.Add
    '-- Si el rango a copiar contiene enlaces aislar la primera línea y liberar las líneas de debajo
    Sourcewb.Sheets(Feuille).Range(Plage).Copy
    Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteFormats '---- copia los formatos
    Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteValues '----- copia los valores
    Destwb.ActiveSheet.[A1].Select
    '--------------------------- Determinar la versión de Excel y la extensión del archivo utilizado
    With Destwb
    If Val(Application.Version) < 12 Then
    '--------------------------- Excel 97-2003
    FileExtStr = ".xls": FileFormatNum = -4143
    Else
    '--------------------------- Excel 2007-2010
    If Sourcewb.Name = .Name Then
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
    MsgBox "Votre réponse est NON dans la boîte de dialogue de sécurité"
    Exit Sub
    Else
    Select Case Sourcewb.FileFormat
    Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
    Case 52:
    If .HasVBProject Then
    FileExtStr = ".xlsm": FileFormatNum = 52
    Else
    FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    Case 56: FileExtStr = ".xls": FileFormatNum = 56
    Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
    End Select
    End If
    End If
    End With
    TempFilePath = Environ$("temp") & "\"
    '-------------------------- Nombre del libro enviado con día y hora de envío
    TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    .Close savechanges:=False
    End With
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1 ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = C_Ent '-------------- Saisir le SMTP du serveur sortant ex."smtp.free.fr"
    .Item("http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress") = Exped 'adresse email de réponse expéditeur
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = NumPort '-------- n° port du serveur sortant
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Typ_Conex '---------- Connexion particulière
    '--------------------------- Si la connexion nécessite une authentification libérer les 3 lignes
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
    'ou
    ' .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = N_Messag ' Nom utilisateur messagerie sinon False
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass ' motdepasse sinon False
    .Update
    End With
    With iMsg
    Set .Configuration = iConf
    .To = Dest
    .CC = CC
    .BCC = BCC
    .From = Exped
    .Subject = [C1].Value
    .TextBody = "Bonjour" & " " & [C2].Value & "," & vbCrLf & vbCrLf _
    & "Veuillez trouvez ci-joint le " & [C3].Value & "." & vbCrLf & vbCrLf _
    & [C4].Value & vbCrLf _
    & [C5].Value & vbCrLf _
    & [C6].Value & vbCrLf _
    & [C7].Value & vbCrLf _
    & [C8].Value & vbCrLf _
    & [C9].Value & vbCrLf _
    & [C10].Value & vbCrLf & vbCrLf _
    & [C11]
    .AddAttachment TempFilePath & TempFileName & FileExtStr
    .Send
    End With
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
    MsgBox "Le mail a été bien envoyé !" '------------- Facultatif, confirmation de l'envoi
    Exit Sub
    '--------------------------- Si erreur on sort de la procédure
    errorHandler:
    '--------------------------- Description de l'erreur survenue
    MsgBox Err.Description
    '--------------------------- Si erreur ferme la copie temporaire
    For Each Wb In Workbooks
    If Left(Wb.Name, 1) <> "Claseur" And Wb.Name <> ThisWorkbook.Name Then
    Wb.Close
    End If
    Next Wb
    End Sub

    --

    A+
    Mike-31

    Une période d'échec est un moment rêvé pour semer les graines du savoir.
    0
    1. eriiic Mensajes publicados 24581 Fecha de registro   Estado Colaborador Última intervención   7 281
       
      Hola a todos,

      he leído a la ligera pero ¿no faltaría un .PasteSpecial Paste:=xlPasteColumnWidths para responder a la solicitud?

      eric
      0
    2. Mike-31 Mensajes publicados 18205 Fecha de registro   Estado Colaborador Última intervención   5 147
       
      Hola,

      en la solicitud, debe "conservar todo excepto los anchos de columna"

      no sé, ya veremos

      A+
      Mike-31
      0
  4. maya
     
    Hola
    Hice un intento, tengo un mensaje que dice imposible pegar celdas combinadas de diferentes tamaños.
    Al principio tengo columnas de la A a la AA con anchura de columna de 3 a 4, cuando recibo el archivo pegado por correo y lo abro, tengo columnas de anchura 10.38
    He puesto el archivo de ejemplo en línea, podría ser más sencillo y mejor que mis explicaciones:
    http://cjoint.com/12oc/BJwrFPNiCOb.htm
    @+
    0
  6. maya
     
    pequeña precisión: el archivo definitivo será protegido, ¿esto puede tener alguna incidencia?
    0
  7. Mike-31 Mensajes publicados 18205 Fecha de registro   Estado Colaborador Última intervención   5 147
     
    Coloca simplemente este código en lugar del otro, completa las constantes

    Const Dest As Variant = "wwwwwwwwww@free.fr"
    Const Exped As Variant = "www.xxxxxxx@free.fr"
    Const C_Ent As Variant = "SMTP.free.fr"

    Si se bloquea habrá que mirar en tu correo el N° del puerto saliente, pero ya te diré más tarde, normalmente es el 25

    Option Explicit

    Sub Envoi_Mail()

    Dim cdoBasic
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb, Destwb As Workbook
    Dim TempFilePath, TempFileName As String
    Dim Wb, iMsg, iConf As Object
    Dim Flds As Variant
    '--------------------------- Constante a completar
    Const Feuille As Variant = "FORMULAIRE" '------------- nombre de la hoja a copiar
    Const Plage As Variant = "Cells" '------------------- rango a copiar, (Cells.Copie toda la hoja)
    Const Dest As Variant = "wwwwwwwwww@free.fr" '- dirección postal del destinatario
    Const Exped As Variant = "www.xxxxxxx@free.fr" '------ dirección de correo de respuesta del remitente
    Const C_Ent As Variant = "SMTP.free.fr" '------------- dirección del SMTP (correo entrante)
    Const CC As Variant = "" '---------------------------- dirección de correo CC
    Const BCC As Variant = "" '--------------------------- dirección de destinatario para envío BCC o BCI o CCI
    Const NumPort As Variant = 25 '----------------------- nº de puerto del servidor saliente
    Const Nom_envoi As Variant = "Sourcewb.Name" '----------- nombre identico del archivo enviado o reemplazar por "Nombre deseado"
    '--------------------------- Si la conexión requiere autenticación
    Const N_Messag As Variant = "False" '----------------- Nombre de usuario del correo, si no, poner "False"
    Const Pass As Variant = "False" '--------------------- contraseña si no, poner en False
    '--------------------------- Conexión SSL como Gmail y Hotmail etc... poner la constante en "True" de lo contrario "False"
    Const Typ_Conex As Variant = "False"

    '--------------------------- Inicio del procedimiento
    On Error GoTo errorHandler
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    End With
    Set Sourcewb = ActiveWorkbook
    Set Destwb = Workbooks.Add
    '-- Si el rango a copiar contiene enlaces aislar la primera fila y liberar las filas de abajo
    Sourcewb.Sheets(Feuille).Cells.Copy Destwb.ActiveSheet.[A1]
    ' Sourcewb.Sheets(Feuille).Range(Plage).Copy Destwb.ActiveSheet.[A1]
    ' Sourcewb.Sheets(Feuille).Range(Plage).Copy
    ' Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteFormats '---- copia los formatos
    ' Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteValues '----- copia los valores
    ' Destwb.ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths '---- copia los anchos de columna
    ' Destwb.ActiveSheet.[A1].Select
    '--------------------------- Determinar la versión de Excel y la extensión del archivo utilizado
    With Destwb
    If Val(Application.Version) < 12 Then
    '--------------------------- Excel 97-2003
    FileExtStr = ".xls": FileFormatNum = -4143
    Else
    '--------------------------- Excel 2007-2010
    If Sourcewb.Name = .Name Then
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
    MsgBox "Votre réponse est NON dans la boîte de sécurité"
    Exit Sub
    Else
    Select Case Sourcewb.FileFormat
    Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
    Case 52:
    If .HasVBProject Then
    FileExtStr = ".xlsm": FileFormatNum = 52
    Else
    FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    Case 56: FileExtStr = ".xls": FileFormatNum = 56
    Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
    End Select
    End If
    End If
    End With
    TempFilePath = Environ$("temp") & "\"
    '-------------------------- Nombre del libro enviado con día y hora de envío
    TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    With Destwb
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
    .Close savechanges:=False
    End With
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    iConf.Load -1 ' CDOSource Defaults
    Set Flds = iConf.Fields
    With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = C_Ent '-------------- Escribir el SMTP del servidor saliente por ejemplo "smtp.free.fr"
    .Item("http://schemas.microsoft.com/cdo/configuration/senduserreplyemailaddress") = Exped 'dirección de correo de respuesta del remitente
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = NumPort '-------- nº de puerto del servidor saliente
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = Typ_Conex '---------- Conexión particular
    '--------------------------- Si la conexión requiere autenticación liberar las 3 líneas
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
    'o
    ' .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = N_Messag ' Nombre de usuario del correo si no False
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Pass ' contraseña si no False
    .Update
    End With
    With iMsg
    Set .Configuration = iConf
    .To = Dest
    .CC = CC
    .BCC = BCC
    .From = Exped
    .Subject = [C1].Value
    .TextBody = "Bonjour" & " " & [C2].Value & "," & vbCrLf & vbCrLf _
    & "Veuillez trouvez ci-joint le " & [C3].Value & "." & vbCrLf & vbCrLf _
    & [C4].Value & vbCrLf _
    & [C5].Value & vbCrLf _
    & [C6].Value & vbCrLf _
    & [C7].Value & vbCrLf _
    & [C8].Value & vbCrLf _
    & [C9].Value & vbCrLf _
    & [C10].Value & vbCrLf & vbCrLf _
    & [C11]
    .AddAttachment TempFilePath & TempFileName & FileExtStr
    .Send
    End With
    With Application
    .ScreenUpdating = True
    .EnableEvents = True
    End With
    MsgBox "Le mail a été bien envoyé !" '------------- Confirmación de envío (opcional)
    Exit Sub
    '--------------------------- Si se produce un error, salimos del procedimiento
    errorHandler:
    '--------------------------- Descripción del error ocurrido
    MsgBox Err.Description
    '--------------------------- Si hay un error, cierra la copia temporal
    For Each Wb In Workbooks
    If Left(Wb.Name, 1) <> "Claseur" And Wb.Name <> ThisWorkbook.Name Then
    Wb.Close
    End If
    Next Wb
    End Sub

    --
    A+
    Mike-31

    Una période d'échec est un moment rêvé pour semer les graines du savoir.
    0
    1. eriiic Mensajes publicados 24581 Fecha de registro   Estado Colaborador Última intervención   7 281
       
      Hola Mike,

      sigues intentando cerrar todos los archivos que empiezan por "claseur" (con una sola s).
      Pero no deberías cerrar ninguno salvo el que fue creado (si lo fue): TempFileName & FileExtStr

      eric
      0
  8. fabidou49 Mensajes publicados 1 Estado Miembro
     
    Primero, gracias a las personas que explicaron y proporcionaron esta macro.

    En mi equipo funciona muy bien, pero en lugar de enviar el libro en formato .xls, quiero enviarlo en formato PDF. Intenté reemplazar .xls por .pdf, pero la persona que recibe el documento no puede abrirlo. Me gustaría saber cómo proceder.

    Además, también me gustaría guardar la hoja enviada (siempre en PDF) en la carpeta "c: ..... " para conservar una constancia de mi envío.

    Última petición, y disculpen que sea tan exigente, la hoja que hago es un recibo de alquiler. Consigo poner la fecha de envío automáticamente, pero me gustaría poder escribir esto, en una o varias celdas de forma automática como la fecha, por ejemplo: período del xxx al xxx. Los "xxx" serán reemplazados por el periodo que cubre el recibo, es decir del 01 de marzo de 2013 al 31 de marzo de 2013. Por lo tanto, hay que gestionar si el mes tiene 30 días o 31 o 28 para febrero.

    Les agradezco de antemano sus luces.
    0
Anterior
  • 1
  • 2