Outlook 2007 add-in to set standard zoom levels
Particularly on a high resolution screen it may be difficult to read mail messages in Outlook due to small character size. With Outlook 2007 it is not possible to save the zoom settings for new messages from one session to the other. And although it is possible to set the character size of the message list it is a rather complicated procedure for inexperienced users.
This add-in for Outlook will add a Zoom menu to the menu bar. Clicking on it will open a window which allows you to set the standard zoom level for new messages. Also it is possible here to set and save the character size for the message list view.
These screenshots show examples of what the Zoom dialog window looks like. The most essential code is listed below.
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