Discussion :

[Invité]

Bonjour à tous,
J'ai créer un fichier excel avec 3 feuilles. feuil 1 feuil 2 et feuil 3
le fichier permet en un bouton d'envoyer la feuille 1 par mail (outlook) au adresses mail présentes dans la feuille 2, ainsi qu'enregistrer une copie de la feuille envoyé dans un dossier de la même racine spécifié dans la feuille 3.
Sa marche très bien sur mon ordi.
Aujourd'hui j'ai essayé de mettre la même chose sur l'ordi d'un collègue qui utilise un ordi identique au miens (win10, office 365) et un message s'erreur d'est affiché)

voici le message d'erreur

voici le message du débogueur

voici le code du module 1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
'http://www.developpez.net/forums/d1342044/logiciels/microsoft-office/excel/macros-vba-excel/exporter-images-en-vba/
 
Option Explicit
 
Dim MonItem As Outlook.MailItem
 
'Requiert une référence à la bibliothèque d'objets Word
Dim wdDoc As Word.Document
Dim PathName As String
Dim lapj As String
 
Public Sub essai_mail()
 
PathName = ThisWorkbook.Path & "\" & Range("pSubFolder") & "\"
lapj = PathName & Range("pFileName").Value
 
Application.DisplayAlerts = False
 
ThisWorkbook.Worksheets(Array("SP")).Copy
 
 
With ActiveWorkbook
        .SaveAs _
                Filename:=lapj, _
                FileFormat:=xlOpenXMLWorkbook
        .Close
End With
 
Call Envoi_Documents_Mail
 
Application.DisplayAlerts = False
 
End Sub
 
Sub Envoi_Documents_Mail()
 
'Si Otlook ouvert : ferme la session et en ouvre une autre vierge
'Si Outlook fermé : ouvre une session
 
'Call Test_Open_Outlook
 
'Utilise la liaison anticipée
'Requiert une référence à la bibliothèque d'objets Outlook
Dim Applic_Outlook As Outlook.Application
 
Dim édit_ol As Outlook.Inspector
 
Dim dermail As Byte
Dim liste_adresses As String
Dim c As Range
Dim PathName As String
liste_adresses = ""
With ThisWorkbook.Worksheets("liste_Mails")
        dermail = .Cells(.Rows.Count, 1).End(xlUp).Row
        For Each c In .Range("D7:D327" & dermail)
                With c
                        If .EntireRow.Hidden = False Then _
                                    liste_adresses = liste_adresses & .Value & ";"
                End With
        Next c
End With
 
'supprimer le dernier point virgule
liste_adresses = Left(liste_adresses, Len(liste_adresses) - 1)
 
 'cellule date de la fiche
 
Dim objet_mail As String
objet_mail = Range("pObject")
 
Application.ScreenUpdating = False
 
'Crée l'objet Outlook
Set Applic_Outlook = New Outlook.Application
 
'Créer l'élément de mail et le transmettre
Set MonItem = Applic_Outlook.CreateItem(olMailItem)
 
With MonItem
 
        .BodyFormat = olFormatHTML
        .To = liste_adresses
        .Subject = objet_mail
        .Display
        .Attachments.Add lapj
        Application.Wait (Now + TimeValue("0:00:01"))
        .Display
 
        On Error Resume Next
        AppActivate objet_mail & " - Message (HTML)" ' Active Outlook
        AppActivate objet_mail & " - Message" ' Active Outlook
        On Error GoTo 0
 
        'https://www.developpez.net/forums/d1334291/logiciels/microsoft-office/outlook/vba-outlook/copier-coller-tableau-excel-corps-mail/
        Set édit_ol = .GetInspector
        'Portée Module
       ' Set wdDoc = édit_ol.WordEditor
 
        'copie du corps de texte dans le corps de message
        Call Création_img
 
        Set wdDoc = Nothing
        Set édit_ol = Nothing
 
       '.Send
 
        Application.CutCopyMode = False
 
End With
 
Set MonItem = Nothing
Set Applic_Outlook = Nothing
 
ActiveWindow.DisplayGridlines = True
 
End Sub
 
Sub Création_img()
 
Dim S As Shape
 
With Worksheets("liste_mails")
 
        .Activate
 
        ActiveWindow.DisplayGridlines = False
 
        'Précaution éventuelle, suppression de toutes les images
        'If .Shapes.Count > 0 Then
                'For Each S In .Shapes
                       ' With S
                              '  If InStr(.Name, "Retour") + InStr(.Name, "Logo") = 0 Then .Delete
                      '  End With
                'Next S
      '  End If
 
        '.Range("corps_message").CopyPicture Appearance:=xlScreen, Format:=xlPicture
 
        '.Paste
 
        '.Shapes(.Shapes.Count).Copy
 
       '  Application.CutCopyMode = False
 
      ' .Shapes(.Shapes.Count).Delete
 
End With
 
End Sub

voici le code du mudule 2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
 Public Declare PtrSafe Function FindWindowA _
        Lib "user32" ( _
            ByVal Hwnd As Long, _
            ByVal hWndInsertAfter As Long, _
            ByVal x As Long, ByVal y As Long, _
            ByVal cx As Long, ByVal cy As Long, _
            ByVal wFlags As Long) _
    As Long
 
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
 
''https://www.extendoffice.com/documents/excel/2030-keep-excel-window-on-top.html
 
Sub Test_Open_Outlook()
 
Dim Chemin As String
Chemin = "C:\Program Files (x86)\Microsoft Office\root\Office16\OUTLOOK.exe"
 
Dim Appli As Object
Dim session_Outlook As New Outlook.Application
Dim Ole_appli As Object
 
Dim typouv As Byte
typouv = 1
 
On Error Resume Next
Set Appli = GetObject(, "Outlook.Application")
 
Call ShowXLOnTop(True)
 
If Appli Is Nothing Then
 
      'Ouvre Outlook
        session_Outlook = Shell(Chemin, typouv)
 
Else
 
        'Fermeture de l'application Outlook si ouverte et réouverture d'une nouvelle
        Call KillProcess("Outlook.exe")
 
        session_Outlook = Shell(Chemin, typouv)
 
End If
 
Set Ole_appli = Nothing
Set Appli = Nothing
 
Call ShowXLOnTop(False)
 
End Sub
 
Sub ShowXLOnTop(ByVal OnTop As Boolean)
    Dim xStype As Long
 
Dim xHwnd As Long
 
If OnTop Then
        xStype = HWND_TOPMOST
    Else
        xStype = HWND_NOTOPMOST
    End If
    Call SetWindowPos(Application.Hwnd, xStype, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE)
End Sub
 
 'https://vb.developpez.com/faq/?page=Systeme#killprocess
 
 Public Function KillProcess(ByVal ProcessName As String) As Boolean
    Dim svc As Object
    Dim sQuery As String
    Dim oproc
    Set svc = GetObject("winmgmts:root\cimv2")
    sQuery = "select * from win32_process where name='" & ProcessName & "'"
    For Each oproc In svc.execquery(sQuery)
        oproc.Terminate
    Next
    Set svc = Nothing
End Function

Je comprends pas sur mon ordi sa marche....merci pour votre aide !