Oliv-

Avec OUTLOOK 2013 et 2016 il n'est plus possible d'insérer une signature à l'aide de CommandBars

Code VB :

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

   mail.GetInspector.CommandBars.item("Insert").Controls("Signature").Controls("interne").Execute   'insertion de la signature se nommant "INTERNE"

Les méthodes utilisables avec ces Versions consistent à LIRE le contenu des Fichiers SIGNATURES qui se trouvent là

%AppData%\Microsoft\Signatures

ici des exemple https://www.slipstick.com/developer/...signature-vba/


Et bien, voici 2 méthodes la première utilise le Ruban et clic sur la signature de son choix

Code VB :

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
'---------------------------------------------------------------------------------------
' Module    : Signature
' Author    : Oliv
' Date      : 01/11/2017
' Purpose   : insert SIGNATURE in OUTLOOK 2016
'---------------------------------------------------------------------------------------
'##############Please add reference ###############
'            UIAutomationClient
'##################################################
 
Option Explicit
Dim oApp
 
'Declare UIAutomationClient variable
Dim uiAuto As UIAutomationClient.CUIAutomation
Dim elmRibbon As UIAutomationClient.IUIAutomationElement
Dim elmRibbonTab As UIAutomationClient.IUIAutomationElement
Dim cndProperty As UIAutomationClient.IUIAutomationCondition
Dim aryRibbonTab As UIAutomationClient.IUIAutomationElementArray
Dim ptnAcc As UIAutomationClient.IUIAutomationLegacyIAccessiblePattern
Dim accRibbon As Office.IAccessible
Dim i As Long
 
'Declare sleep
#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)    'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)    'For 32 Bit Systems
#End If
 
'Declare mouse events
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
 
 
 
 
Sub Insert_Signature()
'---------------------------------------------------------------------------------------
' Procedure : Insert_Signature
' Author    : Oliv
' Date      : 02/11/2017
' parameter : replace in line [Call ClicSequence(Array("Une Signature", "Oliv"))]
' "Une Signature" = Label of Signature MenuItem in the ribbon
' "Oliv" = the signature
'---------------------------------------------------------------------------------------
'
    On Error Resume Next
    If UCase(Application) = "OUTLOOK" Then
        Set oApp = Application
    Else
        Set oApp = CreateObject("outlook.application")
    End If
 
    Set uiAuto = New UIAutomationClient.CUIAutomation
 
 
    Set accRibbon = oApp.ActiveInspector.CommandBars("Ribbon")
    If accRibbon Is Nothing Then Exit Sub
    Set elmRibbon = uiAuto.ElementFromIAccessible(accRibbon, 0)
 
    If SelectRibbonTab("Message") Then
 
        'Dans la version Française le nom du MenuItem SIGNATURE est différent entre OFFICE 2010 et 2016
        If Val(oApp.Version) = 14 Then
            Call ClicSequence(Array("Signature", "Oliv"))
        Else
            Call ClicSequence(Array("Une Signature", "Oliv"))
        End If
    End If
 
End Sub
 
 
Private Function SelectRibbonTab(NAME) As Boolean
    SelectRibbonTab = False
    Set cndProperty = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, "NetUIRibbonTab")
    Set aryRibbonTab = elmRibbon.FindAll(TreeScope_Subtree, cndProperty)
 
    For i = 0 To aryRibbonTab.Length - 1
        Set elmRibbonTab = aryRibbonTab.GetElement(i)
        If Not elmRibbonTab Is Nothing Then
            If elmRibbonTab.CurrentControlType = UIA_TabItemControlTypeId And StrComp(elmRibbonTab.CurrentName, NAME, vbTextCompare) = 0 Then
                Set ptnAcc = elmRibbonTab.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
                ptnAcc.DoDefaultAction
                DoEvents
                Exit For
            End If
        End If
    Next
    If Not ptnAcc Is Nothing Then
        ' DoEvents
        Sleep 50
        SelectRibbonTab = True
    End If
 
End Function
 
Private Sub ClicSequence(ByVal SeqName As Variant)
    Dim sequence As Variant, truc
    sequence = Array(Array(SeqName(0), "NetUIAnchor"), Array(SeqName(1), "NetUITWBtnCheckMenuItem"))
    '"NetUIGalleryButton"))
    For Each truc In sequence
        Set cndProperty = uiAuto.CreatePropertyCondition(UIA_ClassNamePropertyId, truc(1))
 
        If truc(0) = SeqName(1) Then
            Set cndProperty = uiAuto.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_IsControlElementPropertyId, True)
        End If
        Set aryRibbonTab = elmRibbon.FindAll(TreeScope_Subtree, cndProperty)
 
        For i = 0 To aryRibbonTab.Length - 1
            Debug.Print aryRibbonTab.GetElement(i).CurrentName
            If StrComp(aryRibbonTab.GetElement(i).CurrentName, truc(0), vbTextCompare) = 0 Then
                Set elmRibbonTab = aryRibbonTab.GetElement(i)
                Exit For
            End If
        Next
        If elmRibbonTab Is Nothing Then Exit Sub
        Set ptnAcc = elmRibbonTab.GetCurrentPattern(UIA_LegacyIAccessiblePatternId)
        'Debug.Print vbTab & ptnAcc.CurrentName
        Dim pt As UIAutomationClient.tagPOINT
 
        If truc(0) = SeqName(1) Then
            elmRibbonTab.GetClickablePoint pt
            Clickpoint pt.x, pt.y
        Else
            ptnAcc.DoDefaultAction
 
        End If
 
        Set elmRibbonTab = Nothing
        'DoEvents
        Sleep 400
    Next truc
End Sub
Private Sub Clickpoint(x, y)
    SetCursorPos x, y
    Sleep 50
    mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
 
    mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

La seconde IMPORTE le fichier signature AVEC les images et permet de changer de Signature en utilisant le ruban.

Code VB :

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
 
Sub InsertSignature(objMail As Object, Optional SignatureName As String)
'---------------------------------------------------------------------------------------
' Procedure : InsertSignature
' Author    : OLiv
' Version   : 2.2
' Date      : 18/06/2020
' Purpose   : Ajout d'une signature pour OUTLOOK 2010,2013,2016,365
'---------------------------------------------------------------------------------------
'
    Dim wd As Object, obSelection As Object
    Dim oBookmarks As Object, oBookmark As Object    'Word.Bookmark
    Dim enviro, strSigFilePath
    Const wdStory = 6
    Const wdParagraph = 4
    Const wdGoToBookmark = -1
    Const wdExtend = 1
    Const wdSortByName = 0
    Const wdMove = 0
    enviro = CStr(Environ("appdata"))
    strSigFilePath = enviro & "\Microsoft\Signatures\"
 
 
    Set wd = objMail.GetInspector.WordEditor
 
 
    If SignatureName = "" Then
        Dim objSig As Object
        Set objSig = wd.Application.EmailOptions.EmailSignature
        SignatureName = objSig.NewMessageSignature
 
    End If
 
    Set obSelection = wd.Application.Selection
 
    Set oBookmarks = wd.Bookmarks
 
    On Error Resume Next
    Set oBookmark = oBookmarks("_MailAutoSig")
    On Error GoTo 0
    If oBookmark Is Nothing Then
    'si pas de bookmark signture je vais à la fin.
        Set obSelection = wd.Application.Selection
        obSelection.EndOf Unit:=wdStory, Extend:=wdMove
  '      obSelection.Move wdStory, -1
        obSelection.Move wdParagraph, 1
        obSelection.Paragraphs.Add
        obSelection.Move wdParagraph, 1
        Set oBookmark = obSelection.Bookmarks.Add("_MailAutoSig", obSelection.Range)
        oBookmark.Range.Text = "_Signature"
        oBookmark.End = wd.Range.End
    End If
 
    If Dir(strSigFilePath & SignatureName & ".htm", vbNormal) <> "" Then
 
        'oBookmark.Select
        Dim orng As Object    'Word.Range
        Set orng = wd.Range
        orng.Start = orng.Bookmarks("_MailAutoSig").Range.Start
        orng.End = orng.Bookmarks("_MailAutoSig").Range.End
        orng.InsertFile Filename:=strSigFilePath & SignatureName & ".htm", Range:="", ConfirmConversions:= _
                        False, Link:=False, Attachment:=False
        orng.End = wd.Range.End
        With wd.Bookmarks
            .Add Range:=orng, Name:="_MailAutoSig"
            .DefaultSorting = wdSortByName
            .ShowHidden = False
        End With
 
        'On Error Resume Next
        'Set oBookmark = wd.Bookmarks("_MailAutoSig")
        ' oBookmark.End = wd.Range.End
        'oBookmark.Select
 
        obSelection.Move wdStory, -1
    End If
End Sub

'ICI UN EXEMPLE D'UTILISATION

Code VB :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Sub createMailWithSignature()
 
    Dim objMsg As Outlook.MailItem
 
    Set objMsg = Application.CreateItem(olMailItem)
    With objMsg
        .Subject = "Votre sujet"
        .HTMLBody = "<p>Quelque chose ici.</p><p> </p>"
        .Display
        InsertSignature objMsg, "OLiv"
    End With
 
End Sub