[XL-2013] Envoi de Mail en VBA via l'API Gmail

Bonjour à tous

J'ai souvent trouvé mon bonheur sur le forum mais là je bloque.

J'utilise un code VBA permettant d'envoyer des mails par Gmail grâce à la référence CDO et il fonctionne très bien dès lors que l'accès des applications moins sécurisées est autorisé sur le compte Gmail.

Mon soucis est qu'il me faut maintenant la version qui passe par l'API Gmail afin de ne pas avoir à autoriser cet accès moins sécurisé sur le compte Gmail.

Comme je suis autodidacte et non connaisseur en API, je voudrais savoir si l'API peut être "greffée" sur mon code existant en ajoutant uniquement la connexion Oauth2 ou s'il faut un nouveau code pour faire cela et si dans ce cas quelqu'un peut me communiquer le code à adapter à mes besoins svp?

Ci-joint mon code actuel en CDO.

Merci d'avance à tous pour votre aide

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
Sub SendEmailUsingGmail()
 
 
    On Error GoTo Err
 
    Dim NewMail As Object
    Dim mailConfig As Object
    Dim fields As Variant
    Dim msConfigURL As String
 
    Set NewMail = CreateObject("CDO.Message")
    Set mailConfig = CreateObject("CDO.Configuration")
 
    ' load all default configurations
    mailConfig.Load -1
 
    Set fields = mailConfig.fields
 
    With NewMail
        .Subject = "Test Mail"
        .From = "XXXX@gmail.com"
        .To = "XXXX@lgcf.fr" ' mettre ; entre chaque adresse mail
        .CC = ""
        .BCC = ""
        .TextBody = "Test envoi"
        .HTMLBody = "E-mail envoyé en VBA via Gmail."
    End With
 
    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"
 
    With fields
        'Enable SSL Authentication
        .Item(msConfigURL & "/smtpusessl") = True
 
        'Make SMTP authentication Enabled=true (1)
        .Item(msConfigURL & "/smtpauthenticate") = 1
 
        'Set the SMTP server and port Details
        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"
        .Item(msConfigURL & "/smtpserverport") = 465
        .Item(msConfigURL & "/sendusing") = 2
 
        'Set your credentials of your Gmail Account
        .Item(msConfigURL & "/sendusername") = "XXXXX@gmail.com"
        .Item(msConfigURL & "/sendpassword") = "mot de passe"
 
        'Update the configuration fields
        .Update
 
    End With
    NewMail.Configuration = mailConfig
    NewMail.Send
    MsgBox ("OK, c'est parti !")
 
Exit_Err:
 
    Set NewMail = Nothing
    Set mailConfig = Nothing
    End
 
Err:
    Select Case Err.Number
 
    Case -2147220973  'Could be because of Internet Connection
        MsgBox " Could be no Internet Connection !!  -- " & Err.Description
 
    Case -2147220975  'Incorrect credentials User ID or password
        MsgBox "Incorrect Credentials !!  -- " & Err.Description
 
    Case Else   'Rest other errors
        MsgBox "Error occured while sending the email !!  -- " & Err.Description
    End Select
 
    Resume Exit_Err
 
End Sub