Microsoft 365 Problème avec la fonction publishobjects

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion dje14
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
D

dje14

XLDnaute Nouveau
Bonjour as tous,

Je souhaiterais copier un tableau excel dans un mail outlook via un bouton sans modification de forme.

J'ai pu voir que pour cela il fallait convertr en HTML.

Pour cela, j'ai pris des bouts de codes VBA sur le net (et oui malheureusement je ne suis pas un expert en la matière, mais plutôt autodidact sur le sujet).

Celle-ci fonctionne mais pas à tous les coups. Je rencontre un problème avec la fonction PublishObjects qui de temps en temps fonctionne mais la plupart du temps non et je n'en trouve malheureusement pas la raison.

Je vous copie ma fonction (qui peu vous sembler aberrante peut-être).

Sub envoimail1()
Dim Fichier As Variant

Dim i As Integer
Worksheets(Array("Feuil1")).Select
Range("A4: D66").Activate

Dim MaMessagerie As Object
Dim MonMessage As Object
Set MaMessagerie = CreateObject("Outlook.Application")
Set MonMessage = MaMessagerie.CreateItem(0)
MonMessage.To = "toto@gmail.com"
MonMessage.Subject = "Bilan du " & Date
Corps = converthtml(Range("A4: D66"))
Corps = Corps & "<p>"
Corps = Replace(Corps, "align=center", "align=left")
MonMessage.Body = contenu
MonMessage.HTMLBody = Corps
MonMessage.Send
Set MaMessagerie = Nothing

MsgBox "Bilan envoyé"

End Sub

Function converthtml(plage As Object)
Dim lmf, fso, ts, r
Range("Feuil1").Cells(1, 1).Select
lmf = "abctext.html"
With ActiveWorkbook.PublishObjects.Add(xlSourceRange, lmf, plage.Parent.Name, plage.Address, xlHtmlStatic, "Book1_26691", "")
.Publish (True)
.AutoRepublish = False
End With
Set fso = CreateObject("scripting.filesystemobject")
Set ts = fso. OpenTextfile(lmf)
r = ts.readall
ts.Close
converthtml = r
End Function

Merci d'avance pour votre aide.

Cdt
 
Trier par date Trier par votes
Hello dje14,
j'ai une autre méthode à te proposer mais il y a des soucis avec les accents (é par exemple).
As-tu des accents dans les données que tu veux transformer en HTML ? Il me semble que la fonction que tu utilises aura le même genre de problème. Est-ce le cas ?
Ami calmant, J.P
 
Vote positif 0 Vote négatif
jurassic pork à dit:
Hello dje14,
j'ai une autre méthode à te proposer mais il y a des soucis avec les accents (é par exemple).
As-tu des accents dans les données que tu veux transformer en HTML ? Il me semble que la fonction que tu utilises aura le même genre de problème. Est-ce le cas ?
Ami calmant, J.P
Cliquez pour agrandir...
Bonjour,

oui effectivement j'ai des accents car ça contient pas mal de texte.

Vous pensez que cela peu venir de là?
 
Vote positif 0 Vote négatif
Bonjour,

peut-être quelque chose comme ceci:
VB: 
Sub EnvoyerTableauOutlook()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim rng As Range
    Dim tableauHTML As String

    ' Étape 1 : Définir la plage de cellules (A4:D66)
    On Error Resume Next
    Set rng = ThisWorkbook.Sheets(1).Range("A4:D66") ' Modifier "Sheets(1)" si besoin pour une autre feuille
    On Error GoTo 0

    ' Vérifier si la plage est valide
    If rng Is Nothing Then
        MsgBox "La plage spécifiée est invalide.", vbExclamation
        Exit Sub
    End If

    ' Étape 2 : Convertir la plage sélectionnée en HTML
    tableauHTML = ConvertirTableauEnHTML(rng)

    ' Étape 3 : Créer une instance d'Outlook
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application") ' Vérifie si Outlook est déjà ouvert
    If OutlookApp Is Nothing Then
        Set OutlookApp = CreateObject("Outlook.Application") ' Si non, ouvre une nouvelle instance
    End If
    On Error GoTo 0

    ' Étape 4 : Créer un nouvel e-mail et insérer le tableau HTML
    Set OutlookMail = OutlookApp.CreateItem(0) ' 0 = nouveau mail
    With OutlookMail
        .To = "" ' Adresse du destinataire (remplissez si besoin)
        .Subject = "Voici le tableau Excel" ' Sujet du mail
        .HTMLBody = tableauHTML ' Contenu HTML avec le tableau
        .Display ' Affiche l'email (remplacez par .Send pour envoyer directement)
    End With

    ' Étape 5 : Nettoyer les objets
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Function ConvertirTableauEnHTML(rng As Range) As String
    Dim objHTML As Object
    Dim objClipboard As Object

    ' Copier la plage en tant que tableau HTML
    rng.Copy
    Set objHTML = CreateObject("HTMLFile")
    Set objClipboard = GetObject("new:{6C0CFF6B-5DC8-11D0-AF13-00C04FD7D062}") ' Accès au presse-papiers
    objClipboard.GetFromClipboard
    objHTML.Body.InnerHTML = objClipboard.GetText(13) ' Récupère le texte HTML du presse-papiers
    ConvertirTableauEnHTML = objHTML.Body.InnerHTML

    ' Nettoyer les objets
    Set objHTML = Nothing
    Set objClipboard = Nothing
End Function

A tester ou modifier

Edit: un fichier serait bienvenu

Nico
 
Dernière édition:
Vote positif 0 Vote négatif
Nicolas JACQUIN à dit:
Bonjour,

peut-être quelque chose comme ceci:
VB: 
Sub EnvoyerTableauOutlook()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim rng As Range
    Dim tableauHTML As String

    ' Étape 1 : Définir la plage de cellules (A4:D66)
    On Error Resume Next
    Set rng = ThisWorkbook.Sheets(1).Range("A4:D66") ' Modifier "Sheets(1)" si besoin pour une autre feuille
    On Error GoTo 0

    ' Vérifier si la plage est valide
    If rng Is Nothing Then
        MsgBox "La plage spécifiée est invalide.", vbExclamation
        Exit Sub
    End If

    ' Étape 2 : Convertir la plage sélectionnée en HTML
    tableauHTML = ConvertirTableauEnHTML(rng)

    ' Étape 3 : Créer une instance d'Outlook
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application") ' Vérifie si Outlook est déjà ouvert
    If OutlookApp Is Nothing Then
        Set OutlookApp = CreateObject("Outlook.Application") ' Si non, ouvre une nouvelle instance
    End If
    On Error GoTo 0

    ' Étape 4 : Créer un nouvel e-mail et insérer le tableau HTML
    Set OutlookMail = OutlookApp.CreateItem(0) ' 0 = nouveau mail
    With OutlookMail
        .To = "" ' Adresse du destinataire (remplissez si besoin)
        .Subject = "Voici le tableau Excel" ' Sujet du mail
        .HTMLBody = tableauHTML ' Contenu HTML avec le tableau
        .Display ' Affiche l'email (remplacez par .Send pour envoyer directement)
    End With

    ' Étape 5 : Nettoyer les objets
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Function ConvertirTableauEnHTML(rng As Range) As String
    Dim objHTML As Object
    Dim objClipboard As Object

    ' Copier la plage en tant que tableau HTML
    rng.Copy
    Set objHTML = CreateObject("HTMLFile")
    Set objClipboard = GetObject("new:{6C0CFF6B-5DC8-11D0-AF13-00C04FD7D062}") ' Accès au presse-papiers
    objClipboard.GetFromClipboard
    objHTML.Body.InnerHTML = objClipboard.GetText(13) ' Récupère le texte HTML du presse-papiers
    ConvertirTableauEnHTML = objHTML.Body.InnerHTML

    ' Nettoyer les objets
    Set objHTML = Nothing
    Set objClipboard = Nothing
End Function

A tester ou modifier

Edit: un fichier serait bienvenu

Nico
Cliquez pour agrandir...
Bonjour,

merci à vous, je viens de tester le code et j'ai une erreur à la ligne

Set objClipboard = GetObject("new:{6C0CFF6B-5DC8-11D0-AF13-00C04FD7D062}") ' Accès au presse-papiers

Après je n'ai pas eu le temps de vraiment analyser.

Cdt
 
Vote positif 0 Vote négatif
bon dje14 , c'est plus compliqué que je ne croyais pour mon problème ( pb d'encodage utf-8) . En ce qui concerne le tien, j'ai vérifié effectivement avec ton code le HTML est bon pour les accents car il est encodé en ANSI ( charset=windows-1252) . Est-ce que ton problème se produit toujours avec les mêmes données ( donc est-ce que cela dépend des données ?) ou bien est-ce aléatoire ? Que se passe-t-il quand il y a un problème ? plantage ? message d'erreur ? rien ?
 
Vote positif 0 Vote négatif
jurassic pork à dit:
bon dje14 , c'est plus compliqué que je ne croyais pour mon problème ( pb d'encodage utf-8) . En ce qui concerne le tien, j'ai vérifié effectivement avec ton code le HTML est bon pour les accents car il est encodé en ANSI ( charset=windows-1252) . Est-ce que ton problème se produit toujours avec les mêmes données ( donc est-ce que cela dépend des données ?) ou bien est-ce aléatoire ? Que se passe-t-il quand il y a un problème ? plantage ? message d'erreur ? rien ?
Cliquez pour agrandir...
les données sont toujours les mêmes. donc je ne pense pas que cela vienne des données.

Le code erreur vba est 1004 la methode publish de l'objet publishobject a échoué.
 
Vote positif 0 Vote négatif
dje14 à dit:
les données sont toujours les mêmes. donc je ne pense pas que cela vienne des données.

Le code erreur vba est 1004 la methode publish de l'objet publishobject a échoué.
Cliquez pour agrandir...
Au lieu de :
VB: 
Range("Feuil1").Cells(1, 1).Select
Essaie d'activer la feuille où se trouve la plage :
Code: 
Sheets(plage.Parent.Name).Activate

J'ai fait un essai avec une boucle de 1000 itérations , moi je n'ai pas d'erreur (Excel 2021, Windows 11) :
VB: 
Dim i As Integer
For i = 1 To 1000
    Corps = converthtml(Sheets("Feuil1").Range("A1:F80"))
Next i

et est-ce que Style de référence R1C1 est coché dans les options (Formules) ? Quand je le coche j'ai tout de suite une erreur 1004.
 
Dernière édition:
Vote positif 0 Vote négatif
Re,
Désolé, j'ai repris et testé, de mon coté ça match

VB: 
Sub EnvoyerTableauEnPieceJointe()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim cheminFichier As String
    Dim rng As Range
    Dim ws As Worksheet

    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez par le nom exact de la feuille
    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "La feuille 'Calendrier' n'existe pas dans ce classeur.", vbExclamation
        Exit Sub
    End If

    Set rng = ws.Range("A4:D66")
    cheminFichier = EnregistrerTableauDansFichier(rng)

    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail
        .To = ""
        .Subject = "Tableau Excel en pièce jointe"
        .body = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint le tableau demandé." & vbCrLf & vbCrLf & "Cordialement,"
        .Attachments.Add cheminFichier
        .display '
    End With

    Kill cheminFichier
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

Function EnregistrerTableauDansFichier(rng As Range) As String
    Dim wbTemp As Workbook
    Dim cheminFichierTemp As String

    Set wbTemp = Workbooks.Add
    rng.Copy
    wbTemp.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
    Application.CutCopyMode = False

    cheminFichierTemp = Environ("TEMP") & "\TableauExport.xlsx"
    wbTemp.SaveAs cheminFichierTemp, FileFormat:=xlOpenXMLWorkbook
    wbTemp.Close False

    EnregistrerTableauDansFichier = cheminFichierTemp
End Function

Nico
 
Vote positif 0 Vote négatif
Correction avec mise en forme et tout,

Code: 
Sub EnvoyerTableauAvecMiseEnFormeEtTaille()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim cheminFichierTemp As String
    Dim tableauPlage As Range
    Dim wbTemp As Workbook
    Dim wsTemp As Worksheet
    Dim sourceRow As Range
    Dim targetRow As Range
    Dim i As Long

    On Error Resume Next
    Set tableauPlage = ThisWorkbook.Sheets("Feuil1").Range("A1:h32")
    On Error GoTo 0

    If tableauPlage Is Nothing Then
        MsgBox "La feuille ou la plage spécifiée n'existe pas.", vbExclamation
        Exit Sub
    End If

    Set wbTemp = Workbooks.Add
    Set wsTemp = wbTemp.Sheets(1)

    tableauPlage.Copy
    wsTemp.Range("A1").PasteSpecial Paste:=xlPasteAll ' Coller tout, y compris la mise en forme
    wsTemp.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths ' Conserver les largeurs des colonnes
    Application.CutCopyMode = False

    For i = 1 To tableauPlage.rows.Count
        wsTemp.rows(i).RowHeight = tableauPlage.rows(i).RowHeight
    Next i

    cheminFichierTemp = Environ("TEMP") & "\TableauAvecMiseEnForme.xlsx"
    wbTemp.SaveAs cheminFichierTemp, FileFormat:=xlOpenXMLWorkbook
    wbTemp.Close False

    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    With OutlookMail
        .To = "" ' Adresse e-mail du destinataire
        .Subject = "Tableau Excel avec mise en forme et taille"
        .body = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint le tableau demandé avec sa mise en forme et taille d'origine." & vbCrLf & vbCrLf & "Cordialement,"
        .Attachments.Add cheminFichierTemp ' Ajouter le fichier en pièce jointe
        .display ' Afficher l'e-mail avant envoi (utilisez .Send pour envoyer directement)
    End With

    Kill cheminFichierTemp ' Supprimer le fichier temporaire
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

    MsgBox "L'e-mail a été créé avec succès. Vérifiez et envoyez-le !", vbInformation
End Sub

Nico
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Résolu(e)
XL 2021 Céer un fichier (.text) avec VBA pour enregistrer les évènements dans un journal
Réponses
4
Affichages
527
arnoldbrice19
A
D
  • Résolu(e)
Microsoft 365 Problème interférences entre macros
Réponses
14
Affichages
147
Phil69970
Phil69970
Cédric06400
  • Résolu(e)
XL 2021 Revenir sur Excel
Réponses
6
Affichages
431
Franc58
F
R
  • Question Question
Microsoft 365 Inserer copie d'ecran ou plage de cellules dans mail
Réponses
4
Affichages
943
romubzh35
R
S
  • Résolu(e)
Microsoft 365 Fusion de 2 macro VBA (selection envoi de mail + envoie de fichier PDF)
Réponses
6
Affichages
2 K
soNZOOO
S
M
  • Question Question
XL 2016 Envoi courriel copier/coller avec mise en forme (corps couuriel)
Réponses
2
Affichages
1 K
MONTREAL2020
M
I
  • Question Question
XL 2019 Envoyer image et mise en forme conditionnelle dans un mail
Réponses
1
Affichages
914
patricktoulon
patricktoulon
M
  • Question Question
XL 2013 Envoyer un mail automatique avec le contenu de la bonne ligne
Réponses
2
Affichages
828
Oneida
Oneida
Philou0607
  • Question Question
XL 2010 Sauts de ligne dans envoi mail sous VBA
Réponses
5
Affichages
5 K
Staple1600
Staple1600
T
  • Question Question
Envoie d'un mail vba sous condition
Réponses
2
Affichages
4 K
TEMAGOULTFARID
T
R
  • Question Question
XL 2016 Envoyer un fichier excel par email via outlook
Réponses
8
Affichages
3 K
rayms
R
A
  • Question Question
XL 2010 Générer mail avec corps de mail / destinataire et PJ
Réponses
0
Affichages
700
Alghorn
A
chris6999
  • Question Question
Microsoft 365 Envoi mail depuis boite Outlook pré-identifiée
Réponses
3
Affichages
2 K
chris6999
chris6999
chris6999
  • Question Question
Microsoft 365 Envoi mail depuis boite Outlook pré-identifiée
Réponses
0
Affichages
674
chris6999
chris6999
F
  • Question Question
XL 2010 Envoi d'un mail notifiant une modification à plusieurs destinataires
Réponses
5
Affichages
1 K
Hasco
Hasco
chris6999
  • Question Question
Microsoft 365 MSG Outlook via VBA pb de lien et de signature
Réponses
0
Affichages
727
chris6999
chris6999
D
  • Question Question
Résolu : email automatique sous excel
Réponses
13
Affichages
1 K
DG-59
D
Magic_Doctor
  • Question Question
Problème avec boucle tordue et la fonction Switch
Réponses
5
Affichages
1 K
Magic_Doctor
Magic_Doctor
N
  • Question Question
XL 2016 Problème macro ouverture Outlook a l'arrièce plan avec la fonction Shell
Réponses
2
Affichages
3 K
NicoleBelge
N
Claudy
  • Question Question
Compile error Can't find project or library
Réponses
11
Affichages
4 K
Dranreb
Dranreb
Retour