- sauvegarde du mail sélectionné dans un répertoire spécifique et copie du lien dans le presse papier - insertion d'un fichier HTML dans le corps du mail - création d'un groupe de contacts à partir des destinataires

OUTLOOK_MACROS.vbs

Public Const save_mail_path = "D:\Utilisateurs\carlo.bauge\Documents\LOREAL\mails\" ' ne pas oublier le "\" final

' sauvegarde les mails sélectionnés et copie les liens vers ces mails
Sub savemail_copypath()
    Dim objItem As MailItem
    Set objItem = ActiveExplorer.Selection.Item(1)
    myGUID = getGUID(objItem.SenderEmailAddress & objItem.To & objItem.Body & objItem.Subject)
    If myGUID <> "" And Not fileExists(save_mail_path & myGUID & ".msg") Then
        objItem.SaveAs save_mail_path & myGUID & ".msg", olMSG
        setClipboard save_mail_path & myGUID & ".msg"
    ElseIf fileExists(save_mail_path & myGUID & ".msg") Then
        setClipboard save_mail_path & myGUID & ".msg"
    Else
        MsgBox "Impossible de sauvegarder le mail :("
    End If
End Sub

' place la string s dans le presse-papier
Sub setClipboard(ByVal s As String)
    Dim clipboard As DataObject
    Set clipboard = New DataObject
    clipboard.SetText s
    clipboard.PutInClipboard
End Sub

Function getGUID(ByVal s As String) As String
    myUID = BASE64SHA1(s)
    myUID = Replace(myUID, "/", "_")
    getGUID = myUID
End Function

' auto-porteur :)
Function fileExists(ByVal fichier As String) As Boolean
    fileExists = (Dir$(fichier, vbNormal) <> "") And (fichier <> "")
End Function

Public Function BASE64SHA1(ByVal sTextToHash As String)

    Dim asc As Object
    Dim enc As Object
    Dim TextToHash() As Byte
    Dim SharedSecretKey() As Byte
    Dim bytes() As Byte
    Const cutoff As Integer = 5

    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")

    TextToHash = asc.GetBytes_4(sTextToHash)
    SharedSecretKey = asc.GetBytes_4(sTextToHash)
    enc.Key = SharedSecretKey

    bytes = enc.ComputeHash_2((TextToHash))
    BASE64SHA1 = EncodeBase64(bytes)
    'BASE64SHA1 = Left(BASE64SHA1, cutoff)

    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function EncodeBase64(ByRef arrData() As Byte) As String

    Dim objXML As Object
    Dim objNode As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")

    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.Text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

' insert the specified HTML file in the mail
Sub InsertHTMLFile()
    Dim insp As Inspector
    Set insp = ActiveInspector
    If insp.IsWordMail Then
        Dim wordDoc As Word.Document
        Set wordDoc = insp.WordEditor
        wordDoc.Application.Selection.InsertFile "C:\Users\carlo.bauge\Box Sync\2_Streams\12 - Good Work\GOODWork_WelcomeEmail_PostFormatted_V1.4.html", , False, False, False
    End If
End Sub

Sub recipients2group()
    Dim olMailItem As Outlook.MailItem
    Dim olRecipients As Outlook.Recipients
    
    Set oInspector = Application.ActiveInspector
    If oInspector Is Nothing Then
        MsgBox "No active inspector"
    Else
        Set NewMail = oInspector.CurrentItem
        If NewMail.Sent Then
            MsgBox "This is not an editable email"
        Else
            ' on récupère les destinataires
            Set olRecipients = NewMail.Recipients
            group_name = InputBox("Name of the new Group", "New Group")
            If group_name <> "" Then
                create_group group_name, olRecipients
                MsgBox "The group " & group_name & " has been successfully created !"
            Else
                MsgBox "Le nom du groupe est incorrect"
            End If
        End If
    End If
End Sub

' crée un groupe de contacts outlook avec le nom gname et les contacts spécifiés
Sub create_group(ByVal gname As String, ByVal contacts As Recipients)
    Dim olDLst As DistListItem
    Dim olNmspc As Outlook.NameSpace
    
    On Error Resume Next
    Set olDLst = olNmspc.GetDefaultFolder(olFolderContacts).Items(gname)
    On Error GoTo 0

    '~~> If not then create it
    If olDLst Is Nothing Then
        Set olDLst = Application.CreateItem(7)
        olDLst.DLName = gname
        olDLst.Save
    Else
        rep = MsgBox("The group '" & gname & "' already exists. Do you want to add these new contacts to it ?", vbYesNo)
        If rep = vbNo Then Exit Sub
    End If
    
    olDLst.AddMembers contacts
    olDLst.Close olSave
    
    Set olNmspc = Nothing
    Set olDLst = Nothing
End Sub