julien0112
XLDnaute Nouveau
Bonjour,
J'ai un tableau dans excel que je copie (range("c4:i22") par exemple) et que je colle en format html dans un email outlook.
Le code est le suivant:
'-----------------------------------------------------------------------'
' Cette routine va créer une instance de Outlook (si
' pas encore démarré) et va ensuite ouvrir une
' fenêtre de type mail. Le corps du message sera
' initialisé avec le contenu d'un fichier de type
' HTML. Ce fichier aura été préalablement
' créé par la routine SendRangeByMail
'
' Nécessite l'ajout d'une référence vers "Microsoft
' Outlook Object Library"
'
'-----------------------------------------------------------------------
Sub PrepareOutlookMail(ByVal sFileName As String)
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Set appOutlook = CreateObject("Outlook.Application")
' Si Outlook n'était pas ouvert, l'instruction
' ci-dessus aura eu pour conséquence de
' démarrer Outlook.
'Ce type de démarrage par automation fait
'apparaître une fenêtre de sécurité qui demande
'à l'utilisateur de permettre au programme de
'continuer.
'
'Le message est "A program is trying to send an
'email. Do you want to allow..."
'
'Dans le cas où l'utilisateur aurait cliqué sur No,
'l'objet appOutlook est égal à Nothing. Il est
'donc impossible de continuer.
If Not (appOutlook Is Nothing) Then
Set oMail = appOutlook.CreateItem(olMailItem)
oMail.HTMLBody = ReadFile(sFileName)
oMail.Display
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub
'-----------------------------------------------------------------------
'
' La routine SendRangeByMail va proposer à
' l'utilisateur de sélectionner une plage de cellules
' en Excel et va ensuite envoyer cette plage par
' mail, dans le corps du mail.
'
'-----------------------------------------------------------------------
Sub SendRangeByMail()
Dim rngeSend As Range
With Application
On Error Resume Next
' Demande à l'utilisateur de sélectionner la
' plage de cellule
Set rngeSend = Range("A116", Range("A116").End(xlDown).End(xlToRight))
'.InputBox(Prompt:="Please select range you wish to send.", Type:=8, Default:=.Selection.Address)
' rngeSend Is Nothing lorsque l'utilisateur ne fait
' aucun choix
If rngeSend Is Nothing Then Exit Sub
On Error GoTo 0
' Exporte la plage vers un fichier de type HTML;
' ceci afin de respecter la mise en page de la
' plage
.ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
' Appelle la routine qui va se charger de créer
' un mail
Call PrepareOutlookMail("C:\Temp\XLRange.htm")
' Le fichier HTML n'est plus nécessaire
Kill "C:\Temp\XLRange.htm"
End With ' With Application
End Sub
'-----------------------------------------------------------------------
'
' Lit le contenu d'un fichier texte et retourne son
' contenu
'
'-----------------------------------------------------------------------
Public Function ReadFile(sFileName) As String
Dim fso As Object, fFile As Object
Dim sTemp As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fFile = fs
penTextFile(sFileName, 1, False)
sTemp = fFile.ReadAll
fFile.Close
Set fFile = Nothing
ReadFile = sTemp
End Function
Sub OrderTicket()
'
Dim sFileName As String
Dim currentSheet As Worksheet
Set currentSheet = ActiveSheet
'le corps du texte du message
Dim strHTML As String
Dim k As Byte, l As Byte
Dim Tableau1 As Range
Dim Tableau2 As Range
Dim OutApp As Object 'Email application
Dim OutMail As Object 'Email
Dim sEmailAdresses As String 'Semicolon separated list of recipients
Dim sEmailCCAdresses As String 'Semicolon separated list of CC recipients
Dim sEmailBCCAdresses As String 'Semicolon separated list of BCC recipients
Dim sEmailSubject As String 'Subject of email
Dim ConditionAV As Variant
sEmailAdresses = Cells(20, 87).Value
sEmailCCAdresses = Cells(21, 87).Value
sEmailBCCAdresses = Cells(22, 87).Value
sEmailSubject = Cells(23, 87).Value
'Copie et coller le tableau
With Application
On Error Resume Next
'tableau Acaht/Vente
Set Tableau1 = Range("C4:I22")
'.InputBox(Prompt:="Please select range you wish to send.", Type:=8, Default:=.Selection.Address)
' rngeSend Is Nothing lorsque l'utilisateur ne fait
' aucun choix
If Tableau1 Is Nothing Then Exit Sub
On Error GoTo 0
' Exporte la plage vers un fichier de type HTML;
' ceci afin de respecter la mise en page de la
' plage
.ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", Tableau1.Parent.Name, Tableau1.Address, 0, "", "").Publish True
sFileName = "C:\Temp\XLRange.htm"
' Appelle la routine qui va se charger de créer
' un mail
'Call PrepareOutlookMail("C:\Temp\XLRange.htm")
' Le fichier HTML n'est plus nécessaire
End With ' With Application
'Creation of email
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sEmailAdresses
.CC = sEmailCCAdresses
.BCC = sEmailBCCAdresses
.Subject = sEmailSubject
.HTMLBody = ReadFile(sFileName)
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Kill "C:\Temp\XLRange.htm"
Range("c4").Select
End Sub
Mon problème se situe dans la mise en page de l'email.
En effet, le tableau est centré et si je clique sur "aperçu avant impression" on ne voit pas la moitié du texte.
Ma question est donc de savoir comment peut on mettre en page cet email?
Merci à tous et excellente semaine,
J.
J'ai un tableau dans excel que je copie (range("c4:i22") par exemple) et que je colle en format html dans un email outlook.
Le code est le suivant:
'-----------------------------------------------------------------------'
' Cette routine va créer une instance de Outlook (si
' pas encore démarré) et va ensuite ouvrir une
' fenêtre de type mail. Le corps du message sera
' initialisé avec le contenu d'un fichier de type
' HTML. Ce fichier aura été préalablement
' créé par la routine SendRangeByMail
'
' Nécessite l'ajout d'une référence vers "Microsoft
' Outlook Object Library"
'
'-----------------------------------------------------------------------
Sub PrepareOutlookMail(ByVal sFileName As String)
Dim appOutlook As Outlook.Application
Dim oMail As Outlook.MailItem
Set appOutlook = CreateObject("Outlook.Application")
' Si Outlook n'était pas ouvert, l'instruction
' ci-dessus aura eu pour conséquence de
' démarrer Outlook.
'Ce type de démarrage par automation fait
'apparaître une fenêtre de sécurité qui demande
'à l'utilisateur de permettre au programme de
'continuer.
'
'Le message est "A program is trying to send an
'email. Do you want to allow..."
'
'Dans le cas où l'utilisateur aurait cliqué sur No,
'l'objet appOutlook est égal à Nothing. Il est
'donc impossible de continuer.
If Not (appOutlook Is Nothing) Then
Set oMail = appOutlook.CreateItem(olMailItem)
oMail.HTMLBody = ReadFile(sFileName)
oMail.Display
Set oMail = Nothing
Set appOutlook = Nothing
End If
End Sub
'-----------------------------------------------------------------------
'
' La routine SendRangeByMail va proposer à
' l'utilisateur de sélectionner une plage de cellules
' en Excel et va ensuite envoyer cette plage par
' mail, dans le corps du mail.
'
'-----------------------------------------------------------------------
Sub SendRangeByMail()
Dim rngeSend As Range
With Application
On Error Resume Next
' Demande à l'utilisateur de sélectionner la
' plage de cellule
Set rngeSend = Range("A116", Range("A116").End(xlDown).End(xlToRight))
'.InputBox(Prompt:="Please select range you wish to send.", Type:=8, Default:=.Selection.Address)
' rngeSend Is Nothing lorsque l'utilisateur ne fait
' aucun choix
If rngeSend Is Nothing Then Exit Sub
On Error GoTo 0
' Exporte la plage vers un fichier de type HTML;
' ceci afin de respecter la mise en page de la
' plage
.ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", rngeSend.Parent.Name, rngeSend.Address, 0, "", "").Publish True
' Appelle la routine qui va se charger de créer
' un mail
Call PrepareOutlookMail("C:\Temp\XLRange.htm")
' Le fichier HTML n'est plus nécessaire
Kill "C:\Temp\XLRange.htm"
End With ' With Application
End Sub
'-----------------------------------------------------------------------
'
' Lit le contenu d'un fichier texte et retourne son
' contenu
'
'-----------------------------------------------------------------------
Public Function ReadFile(sFileName) As String
Dim fso As Object, fFile As Object
Dim sTemp As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fFile = fs
penTextFile(sFileName, 1, False)sTemp = fFile.ReadAll
fFile.Close
Set fFile = Nothing
ReadFile = sTemp
End Function
Sub OrderTicket()
'
Dim sFileName As String
Dim currentSheet As Worksheet
Set currentSheet = ActiveSheet
'le corps du texte du message
Dim strHTML As String
Dim k As Byte, l As Byte
Dim Tableau1 As Range
Dim Tableau2 As Range
Dim OutApp As Object 'Email application
Dim OutMail As Object 'Email
Dim sEmailAdresses As String 'Semicolon separated list of recipients
Dim sEmailCCAdresses As String 'Semicolon separated list of CC recipients
Dim sEmailBCCAdresses As String 'Semicolon separated list of BCC recipients
Dim sEmailSubject As String 'Subject of email
Dim ConditionAV As Variant
sEmailAdresses = Cells(20, 87).Value
sEmailCCAdresses = Cells(21, 87).Value
sEmailBCCAdresses = Cells(22, 87).Value
sEmailSubject = Cells(23, 87).Value
'Copie et coller le tableau
With Application
On Error Resume Next
'tableau Acaht/Vente
Set Tableau1 = Range("C4:I22")
'.InputBox(Prompt:="Please select range you wish to send.", Type:=8, Default:=.Selection.Address)
' rngeSend Is Nothing lorsque l'utilisateur ne fait
' aucun choix
If Tableau1 Is Nothing Then Exit Sub
On Error GoTo 0
' Exporte la plage vers un fichier de type HTML;
' ceci afin de respecter la mise en page de la
' plage
.ActiveWorkbook.PublishObjects.Add(4, "C:\Temp\XLRange.htm", Tableau1.Parent.Name, Tableau1.Address, 0, "", "").Publish True
sFileName = "C:\Temp\XLRange.htm"
' Appelle la routine qui va se charger de créer
' un mail
'Call PrepareOutlookMail("C:\Temp\XLRange.htm")
' Le fichier HTML n'est plus nécessaire
End With ' With Application
'Creation of email
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sEmailAdresses
.CC = sEmailCCAdresses
.BCC = sEmailBCCAdresses
.Subject = sEmailSubject
.HTMLBody = ReadFile(sFileName)
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Kill "C:\Temp\XLRange.htm"
Range("c4").Select
End Sub
Mon problème se situe dans la mise en page de l'email.
En effet, le tableau est centré et si je clique sur "aperçu avant impression" on ne voit pas la moitié du texte.
Ma question est donc de savoir comment peut on mettre en page cet email?
Merci à tous et excellente semaine,
J.
