BvSiT

Outlook 2007 plugin pour configurer le niveau de zoom par défaut

En particulier sur des écrans de très haute résolution on peut avoir des difficultés à lire ses messages dans Outlook à cause du petit format des caractères. Avec Outlook 2007 il n’est pas possible de sauvegarder les paramètres pour l’affichage par défaut des nouveaux messages d’une session sur l’autre. Même s’il est possible de configurer la taille de la police de la liste des messages il s’agit d’une procédure relativement compliquée pour un utilisateur inexpérimenté.

Ce plugin pour Outlook ajoutera un menu Zoom à la barre des tâches. En cliquant sur celui-ci une fenêtre s’ouvrira qui vous permettra de configurer le niveau de zoom par défaut pour les nouveaux messages. Il est également possible d’y configurer et de sauvegarder la taille de la police de la liste des messages.

Ces captures d’écran vous montrent la boîte de dialogue Zoom. Vous trouverez l’essentiel du code ci-dessous.

Download the Outlook 2007 Zoom add-in source files and setup.

 

Imports System.Xml
Imports System.Threading
Imports System.Globalization

Public Class ThisAddIn

    'NB You need the VSTO Runtime to be installed
    'See also
    'http://www.clear-lines.com/blog/post/create-excel-2007-vsto-add-in-msi-installation.aspx
    'You can find the VSTO Runtime usually in 
    'C:\Program Files\Microsoft SDKs\Windows\v6.0A\Bootstrapper\Packages\VSTOR30
    'See also
    'http://social.msdn.microsoft.com/forums/en-US/vsto/thread/64a30e0d-676b-4c08-94f8-d841272d20d2
    'The certificate that you use to sign the code should be in the Trusted Publishers store and
    'should be backed up by a certificate in the Trusted Root Certification Authorities
    'See also http://msdn2.microsoft.com/en-us/library/ms996418.aspx

    Dim WithEvents objInspectors As Outlook.Inspectors
    Dim WithEvents objOpenInspector As Outlook.Inspector
    Dim WithEvents objMailItem As Outlook.MailItem
    Private menuBar As Office.CommandBar
    Private btnSetZoomLevel As Office.CommandBarButton
    Private dlgZoomSettings As ZoomSettingsDialog
    Dim ZoomSettings As New Settings1

    Private Sub ThisApplication_Startup(ByVal sender As Object, ByVal e _
        As System.EventArgs) Handles Me.Startup

        'You can test localization of form dlgZoomSettings by setting .CurrentCulture:
        'Thread.CurrentThread.CurrentCulture = CultureInfo.CreateSpecificCulture("fr-FR")
        'Thread.CurrentThread.CurrentUICulture = CultureInfo.CreateSpecificCulture("fr-FR")
        'Thread.CurrentThread.CurrentUICulture = CultureInfo.CreateSpecificCulture("en-US")

        AddMenuBar()
        'Outlook view settings are saved in XML format. Make sure the view character size is
        'identical to saved setting in the settings file
        If GetViewCharSize() <> ZoomSettings.Item("ViewCharSize") Then
            ZoomSettings.Item("ViewCharSize") = GetViewCharSize()
            ZoomSettings.Save()
        End If
        objInspectors = Application.Inspectors
    End Sub

    Private Sub AddMenuBar()
        'Add button Zoom to menu bar in Outlook
        'See also http://msdn.microsoft.com/en-us/library/office/aa432790(v=office.12).aspx
        Try
            menuBar = Me.Application.ActiveExplorer().CommandBars.ActiveMenuBar
            'Leaving out the optional arg Before results in placing the button as last
            btnSetZoomLevel = menuBar.Controls.Add( _
                                Office.MsoControlType.msoControlButton, , Temporary:=True)
            With btnSetZoomLevel
                .Style = Office.MsoButtonStyle.msoButtonCaption
                .Caption = "&Zoom"
                .FaceId = 65
                .Tag = "d123"
            End With
            AddHandler btnSetZoomLevel.Click, AddressOf btnSetZoomLevel_Click
        Catch Ex As Exception
            MsgBox(Ex.Message)
        End Try
    End Sub

    Public Sub btnSetZoomLevel_Click(ByVal buttonControl As Office. _
            CommandBarButton, ByRef Cancel As Boolean)
        dlgZoomSettings = New ZoomSettingsDialog
        'See also http://satalketo.com/2010/06/get-value-dialog-form/
        With dlgZoomSettings
            If .ShowDialog = Windows.Forms.DialogResult.OK Then
                ZoomSettings.Item("ViewCharSize") = _
                                                   SetViewCharSize(.ComboBoxCharSize.SelectedItem())
                ZoomSettings.Item("ZoomLevel") = _
                                             CInt(Replace(.ListBoxPercentage.SelectedItem, "%", ""))
                ZoomSettings.Save()
            End If
        End With
        dlgZoomSettings = Nothing
    End Sub

    Private Sub Application_Quit() Handles Application.Quit
        objOpenInspector = Nothing
        objInspectors = Nothing
        objMailItem = Nothing
    End Sub

    Private Sub objInspectors_NewInspector(ByVal Inspector As _
                      Microsoft.Office.Interop.Outlook.Inspector) Handles objInspectors.NewInspector
        If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
            objMailItem = Inspector.CurrentItem
            objOpenInspector = Inspector
        End If
    End Sub

    Private Sub objOpenInspector_Activate() Handles objOpenInspector.Activate
        Dim wdDoc As Microsoft.Office.Interop.Word.Document
        wdDoc = objOpenInspector.WordEditor
        wdDoc.Windows(1).Panes(1).View.Zoom.Percentage = ZoomSettings.Item("ZoomLevel")
    End Sub
    Public Function SetViewCharSize(ByVal nCharSize As Integer) As Integer

        'Use of system.xml vs. Microsoft.XMLDOM in VBA
        'see http://msdn.microsoft.com/en-us/library/ms973921.aspx
        Dim nDefaultCharSize As Integer = 8
        If nCharSize < nDefaultCharSize Then
            nCharSize = nDefaultCharSize 'never set char size < default char size
        End If
        SetViewCharSize = nCharSize
        On Error Resume Next
        Dim vCurrent As Outlook.View = _
         Application.GetNamespace("MAPI").GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox) _
                                                                                 .Views("Berichten")
        If Err.Number <> 0 Then
            'In case of French or English Office version
            vCurrent = Application.GetNamespace("MAPI") _
                         .GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox).Views("Messages")
        End If
        If Err.Number Then Exit Function 'no View return with this name and same nCharSize
        Dim objXML As New System.Xml.XmlDocument
        objXML.LoadXml(vCurrent.XML)
        'The node we want to change looks like this:
        'font-size:9pt;background-color:window;color:windowtext
        Dim objXMLNode As System.Xml.XmlNode = objXML.SelectSingleNode("//rowstyle")
        Dim Pos As Integer = 0
        Pos = InStr(1, objXMLNode.InnerXml, "font-size:", 1)
        If Pos > 0 Then
            Pos = InStr(1, objXMLNode.InnerXml, "pt;", 1)
            If Pos > 0 Then
                objXMLNode.InnerText = "font-size:" & nCharSize & Mid(objXMLNode.InnerXml, Pos)
                'Copy the modified XML back to the new view.
                vCurrent.XML = objXML.OuterXml
            End If
        Else
            'default value 8pt will never be saved!
            objXMLNode.InnerText = _
                              "font-size:" & nCharSize & ";background-color:window;color:windowtext"
            vCurrent.XML = objXML.OuterXml
        End If
        vCurrent.Save()
        vCurrent.Apply()   'on opening Outlook this view is selected
        SetViewCharSize = nCharSize
    End Function

    Public Function GetViewCharSize() As Integer

        'Use of system.xml vs Microsoft.XMLDOM in VBA
        'see http://msdn.microsoft.com/en-us/library/ms973921.aspx

        Dim vCurrent As Outlook.View
        vCurrent = _
         Application.GetNamespace("MAPI").GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox) _
                                                                                 .Views("Berichten")
        If Err.Number <> 0 Then
            'In case of French or English Office version
            vCurrent = Application.GetNamespace("MAPI") _
                         .GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox).Views("Messages")
        End If
        If Err.Number Then Exit Function 'no View return with 0

        Dim objXML As New System.Xml.XmlDocument
        objXML.LoadXml(vCurrent.XML)
        Dim objXMLNode As System.Xml.XmlNode = objXML.SelectSingleNode("//rowstyle")
        Dim Pos As Integer = 0
        Pos = InStr(1, objXMLNode.InnerXml, "font-size:", 1)
        If Pos > 0 Then
            Pos = InStr(1, objXMLNode.InnerXml, "pt;", 1)
            If Pos > 0 Then
                GetViewCharSize = _
                   Val(Mid(objXMLNode.InnerXml, InStr(1, objXMLNode.InnerXml, "fontsize:", 1) + 11))
            End If
        Else
            'default value 8pt will never be saved!
            GetViewCharSize = 8
        End If
    End Function
End Class