By GUEST le samedi 01 septembre 2018
Publié dans Kutools for Excel
Réponses 0
Aime 0
Vues 2.6K
Votes 0
J'ai installé kutools pour aider à un projet de travail. Je gère également un grand rapport d'entreprise qui contient une macro créant un e-mail à partir des informations saisies. Cette macro a cessé de fonctionner sur mon ordinateur. Cela fonctionne sur les ordinateurs qui n'ont pas de kutools. Quelqu'un a-t-il déjà rencontré quelque chose comme ça? Voici la macro qui fonctionne très bien sur d'autres ordinateurs :

Sous Mail_Sheet_Outlook_Body()
'Travailler dans Excel 2000-2016
Application.ReferenceStyle = xlA1
Dim rng Comme Plage
Dim OutApp en tant qu'objet
Dim OutMail en tant qu'objet
Estomper xFolder en tant que chaîne
Dim xSht en tant que feuille de travail
Dim xSub en tant que chaîne
Réponse d'atténuation sous forme de chaîne
Dim Msg sous forme de chaîne
Style d'atténuation en tant que chaîne
Estomper le titre en tant que chaîne

Définir xSht = ActiveSheet
Msg = "Êtes-vous sûr de vouloir envoyer ce formulaire par e-mail ?" ' Définir le message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Définir les boutons.
Titre = "E-mail de confirmation d'envoi" ' Définir le titre.
Réponse = MsgBox(Msg, Style)

Si Réponse = vbOui Alors
xFolder = Environ("USERPROFILE") + "\Desktop\" + "\Field Audit Form--" + CStr(xSht.Cells(19, "A").Value) + "--.pdf"
'xSub = "Field Audit for store " + CStr(xSht.Cells(19, "A").Value)
Avec application
.EnableEvents = False
.ScreenUpdating = Faux
Terminer par

Set rng = Rien
Définir rng = ActiveSheet.UsedRange
'Vous pouvez également utiliser un nom de feuille
'Set rng = Sheets("YourSheet").UsedRange

Set OutApp = CreateObject("Outlook.Application")
Définir OutMail = OutApp.CreateItem(0)
Dim varCellvalue As Long




On Error Resume Next
Avec OutMail
.À = ""
.CC = ""
.BCC = ""
.Subject = "Récapitulatif"
.Pièces jointes.Ajouter xFolder
.HTMLBody = Plage vers HTML (rng)
.Display 'ou utilisez .Display

Terminer par
En cas d'erreur GoTo 0

Avec application
.EnableEvents = True
.ScreenUpdating = Vrai
Terminer par

Définir OutMail = Rien
Définir OutApp = Rien
Si fin
End Sub


Fonction RangetoHTML(rng As Range)
' Travailler au bureau 2000-2016
Dim fso en tant qu'objet
Dim ts comme objet
Estomper le fichier temporaire en tant que chaîne
Dim TempWB en tant que classeur

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copiez la plage et créez un nouveau classeur pour coller les données dans
rng.Copier
Définir TempWB = Workbooks.Add(1)
Avec TempWB.Sheets(1)
.Cells(1).PasteColler spécial :=8
.Cells(1).PasteSpecial xlPasteValues, , Faux, Faux
.Cells(1).PasteSpecial xlPasteFormats, , Faux, Faux
.Cellules(1).Sélectionner
Application.CutCopyMode = Faux
On Error Resume Next
.DrawingObjects.Visible = Vrai
.DrawingObjects.Delete
En cas d'erreur GoTo 0
Terminer par

'Publier la feuille dans un fichier htm
Avec TempWB.PublishObjects.Add( _
TypeSource :=xlPlageSource, _
Nom de fichier :=FichierTemp, _
Feuille :=TempWB.Feuilles(1).Nom, _
Source :=TempWB.Sheets(1).UsedRange.Address, _
HtmlType :=xlHtmlStatic)
.Publier (Vrai)
Terminer par

'Lire toutes les données du fichier htm dans RangetoHTML
Définissez fso = CreateObject ("Scripting.FileSystemObject")
Définir ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Fermer
RangetoHTML = Remplacer(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Fermer TempWB
TempWB.Close savechanges :=Faux

'Supprime le fichier htm que nous avons utilisé dans cette fonction
Tuer le fichier temporaire
Définir ts = Rien
Définir fso = Rien
Définir TempWB = Rien

Fonction de fin
Voir l'article complet