Pb Compatibilité version Outlook et Word
Bonjour,
Dans mon entreprise, il y a 2 versions d'office365, en ligne ou sur poste.
Pour permettre au premier de faire fonctionner les macros, ils utilisent leurs anciennes version d'Excel (2010).
J'ai écrit mes programmes avec la 2ème version et après la livraison, on me signale des pb de bibliothèques manquantes qui bloque complètement Excel.
Vue que cela concerne de nombreux utilisateurs, je ne peux pas leur demander d'aller cocher / décocher les bibliothèques Microsoft
Dans mes fichiers, je dois faire appel à Outlook.
Après recherche sur les sites, il semble que des "bonnes" déclarations d'objets pourraient résoudre mon pb, mais je ne sais pas comment faire
J'ai trouvé la fonction suivante pour envoyer des mails avec Outlook
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
| 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"
'Copiez la plage et créez un nouveau classeur pour coller les données dedans
'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
'Publier la feuille dans un fichier htm
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
'Lire toutes les données du fichier htm dans 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=")
'Fermer TempWB
TempWB.Close savechanges:=False
'Supprimer le fichier htm que nous avons utilisé dans cette fonction
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function |
Puis mon code pour envoyer les mails
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
| Sub EnvoiCourriel()
'Mail_Selection_Range_Outlook_Body
'Pour des conseils, voir : http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Fl As Worksheet, NbLg As Integer, Ht As Integer
Dim DestAgt As String, cc As String
Application.ScreenUpdating = False
If Sheets("Données").Visible = False Then Call DeProtegAll
'1 on crée une nouvelle feuille
Sheets.Add After:=Sheets("Données")
Set Fl = ActiveSheet
'2 Coordonnées des destinataires
DestAgt = [K1]
cc = [K2]
Application.DisplayAlerts = True
'3 Corps du mail
Columns("A:A").ColumnWidth = 100
[A1] = "Bonjour"
'Remplissage du mail [A2] = ...
'nb de lg à prendre dans la feuille à partir de la colonne
NbLg = Fl.Range("E" & Application.Rows.Count).End(xlUp).Row '/I\ cas particulier Aspa
Fl.Range("A" & NbLg + 2) = "Superviseur" 'Signature
Fl.Range("A" & NbLg + 2).Font.Italic = True
Fl.Range("A" & NbLg + 3) = Fl.Range("J2") 'nom du superviseur
':::
Set rng = Nothing
On Error Resume Next
'Seules les cellules visibles de la sélection
Set rng = Fl.Range("A1:E" & NbLg + 3) 'plage à copier
' Set rng = Selection.SpecialCells(xlCellTypeVisible)
'Vous pouvez également utiliser une plage fixe si vous le souhaitez
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "La sélection n'est pas une plage ou la feuille est protégée" & _
vbNewLine & "veuillez corriger et réessayer.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = [K1].Value
.cc = [K2].Value
.BCC = ""
.Subject = "SuperV - " & Mid(Sheets("Saisies").Range("I1"), 13) 'Objet
.HTMLBody = RangetoHTML(rng)
.Display 'Affiche du mail
' .Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Application.DisplayAlerts = False
Fl.Delete 'on supprime la feuille du message
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
GestErr:
Call MsgBox("Une feuille portant le même nom est présente dans le fichier." _
& vbCrLf & "" _
& vbCrLf & "Veuillez la supprimer et si vous voulez renvoyer le courriel, double-cliquer sur le Nir concerné." _
& vbCrLf & "" _
& vbCrLf & "Merci" _
, vbCritical, "SuperV - Envoi courriel")
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End Sub |
Est-ce que quelqu'un a une solution à me proposer, svp ? je suis vraiment mal...
