Problème envoi Mail
Bonjour,
j'utilise un code VBA sous un Userform pour envoyer des données enregistrés via des Textbox, mais quand je reçois les données sous ma boite mail, je les reçois que partiellement.
Je prends un exemple si j'enregistre la phrase " Envoi d une boite de chocolat par colis expres", je verrai la phrase jusqu'à chocolat.
Je ne vois pas le souci dans mon code:
Private Sub CommandButton1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "sisi@hotmail.fr"
.CC = ""
.BCC = ""
.Subject = "Demande de BAP"
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Me
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Private Sub Label2_Click()
End Sub
Private Sub TextBox1_Change()
[A2] = TextBox1
End Sub
Private Sub TextBox2_Change()
[A14] = TextBox2
End Sub
Private Sub TextBox3_Change()
[A4] = TextBox3
End Sub
Private Sub TextBox4_Change()
[A6] = TextBox4
End Sub
Private Sub TextBox5_Change()
[A8] = TextBox5
End Sub
Private Sub TextBox6_Change()
[A10] = TextBox6
End Sub
Private Sub TextBox7_Change()
[A12] = TextBox7
End Sub
Private Sub UserForm_Click()
End SubQuelqu'un a une idée?
Bonjour,
Il faut déjà tenter de savoir de où cela peut venir.
As-tu essayé de shunter RangetoHTML en mettant directement la valeur ...
.HTMLBody = RangetoHTML(rng)à remplacer par :
.HTMLBody = " Envoi d une boite de chocolat par colis expres"On découvrira déjà de où cela peut venir.
Ma question surtout est que fait RangetoHTML ? pourquoi ouvrir un nouveau classeur ? quel est le but de ce programme ? si c'est juste pour mettre un texte en format html il y a sans doute plus simple. Je passe pour ma part par la détection des caractères supérieurs à 127 que je remplace par le code html du caractère.
.HTMLBody = " Je vais prendre du chocolat avec la voisine s il te plait depuis longtemps surtout en 1945"Tout s'affiche correctement sur Outlook.
Mon objectif étant de créer un userform sur lequel j'enregistre des données (pas besoin de les sauvegarder ça n'a pas d'utilité) qui vont être retransmis par Outlook à des personnes précises.
Les données ont besoin d'être directement retranscris dans le mail.
J'ai tenté ça:
Dim strbody As String
strbody = "Hi there" & vbNewLine & _
.Range("A1") & vbNewLine & _
.Range("A2") & vbNewLine & _
.Range("A3") & vbNewLine & _
.Range("A4") & vbNewLine & _
.Range("A5") & vbNewLine & _
.Range("A6") & vbNewLine & _
.Range("A7") & vbNewLine & _
.Range("A8")
End With
On Error Resume Next
With OutMail
.To = "silat2200@hotmail.fr"
.CC = ""
.BCC = ""
.Subject = "Demande de BAP"
.HTMLBody = strbody
'.HTMLBody = RangetoHTML(rng)
.Display 'or use .send
End With
On Error GoTo 0Je n'ai fait apparaître que les parties modifiées. Mais tout s'affiche sur la même ligne car les "vbnewline" qui sert à faire les sauts de ligne ne fonctionne pas dans l'envoi d un mail sous outlook. Je cherche encore une solution.
Problème résolu. Merci encore, au final j'ai cherché sous ton conseil de faire au plus simple.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
'You can also use a sheet name
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Sheets("Feuil1")
strbody = "Hi there" & "<B>" & "<br>" & _
.Range("A1") & "</B>" & "<br>" & _
.Range("A2") & "<B>" & "<br>" & "<br>" & _
.Range("A13") & "</B>" & "<br>" & _
.Range("A14") & "<B>" & "<br>" & "<br>" & _
.Range("A3") & "</B>" & "<br>" & _
.Range("A4") & "<B>" & "<br>" & "<br>" & _
.Range("A5") & "</B>" & "<br>" & _
.Range("A6") & "<B>" & "<br>" & "<br>" & _
.Range("A7") & "</B>" & "<br>" & _
.Range("A8") & "<B>" & "<br>" & "<br>" & _
.Range("A9") & "</B>" & "<br>" & _
.Range("A10") & "<B>" & "<br>" & "<br>" & _
.Range("A11") & "</B>" & "<br>" & _
.Range("A12")
End With
On Error Resume Next
With OutMail
.To = "sisi@hotmail.fr"
.CC = ""
.BCC = ""
.Subject = "Demande de BAP"
.HTMLBody = strbody
'.HTMLBody = RangetoHTML(rng)
.send 'or use .display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Me
End SubEn effet, c'est plus clair !
Je suis encore toujours dubitatif sur ce programme RangetoHTML
Si tu veux un programme efficace, voici ce que j'ai réalisé récemment, il prend aussi en compte les caractéristiques de police (italique, gras, souligné) du premier caractère et traite les caractères accentués, cyrilliques etc ... pour ce qui est unicode étendu.
Function RangetoHTML(cellule As Range)
' le but est d'afficher les caractères accentués par leur code nnn au format html &#nnn; (en réalité tous les codes supérieurs à 127)
Dim i As Double
Dim cel As Range
texthtml = ""
For Each cel In cellule
' le but est de récupérer les caractéristiques souligné, gras et italique du premier caractère et l'appliquer au texte
texthtml = texthtml & _
IIf(cel.Characters(Start:=1, Length:=1).Font.Underline <> xlUnderlineStyleNone, "<u>", "") & _
IIf(cel.Characters(Start:=1, Length:=1).Font.Bold, "<b>", "") & _
IIf(cel.Characters(Start:=1, Length:=1).Font.Italic, "<i>", "")
For i = 1 To Len(cel.Value)
Select Case Asc(Mid(cel.Value, i, 1))
Case Is = 10
texthtml = texthtml & "<br/>"
Case Is = 39
texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(cel.Value, i, 1)))) & ";"
Case Is > 127
texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(cel.Value, i, 1)))) & ";"
Case Else
texthtml = texthtml & Mid(cel.Value, i, 1)
End Select
Next
texthtml = texthtml & _
IIf(cel.Characters(Start:=1, Length:=1).Font.Italic, "</i>", "") & _
IIf(cel.Characters(Start:=1, Length:=1).Font.Bold, "</b>", "") & _
IIf(cel.Characters(Start:=1, Length:=1).Font.Underline <> xlUnderlineStyleNone, "</u>", "") & _
"<br/>"
Next cel
End FunctionJe testerai prochainement. Maintenant il faut que je cherche un moyen depuis mon userform d'insérer une pièce jointe qui s'insérera dans le mail. Des pistes?