18 agosto, 2011 a las 20:34

Si hay una herramienta usada en el mundo empresarial es Microsoft Outlook, para bien o para mal cualquier persona pasa horas con ella al día, por esta aplicación pasa muchísima información diaria y por eso es muy importante tenerla siempre activa y funcionando sin problemas. Una caracteristica de Outlook muy usada es el autoarchivado, esta caracteristica descarga los correos del servidor y los guarda en un archivo en el disco duro local para liberar espacio en el servidor y ahorrar ancho de banda, esto es una gran solución pero conlleva un problema y es que si dicho archivo termina superando los 2GB de información Outlook se vuelve especialmente lento e inestable a la hora de trabajar con el, por eso he desarrollado un Addin (codigo fuente mas adelante) que genera un nuevo fichero de archivado cada año, de esta forma reducimos muy considerablemente el riesgo a sobrepasar ese limite y además nos ayuda a tener nuestras carpetas archivadas ordenadas según fechas.

El fichero PST creado  lo guarda en %AppData%/Local settings/Microsoft/Outlook/ y le da este nombre dinámico “archivePerfilAño.pst” donde Perfil seria el nombre de nuestro perfil de Outlook y año el año correspondiente a las carpetas archivadas.

Además, es posible exportar la configuración en un archivo (AutoArchiveByDate.cfg) e importarla con solo copiarla: ideal para instalaciones masivas. Para acceder a la ventana de configuración  debemos ir a un nuevo menú que aparecerá llamado AutoArchiveByDate.

Para los mas curiosos, aquí tenéis el código fuente, consta de un formulario (Form1, ventana de configuracion) que debe contener al menos dos NumericUpDown (nFrecuencia, nAnteriores) un ComboBox (cbFormatoTiempo), dos CheckBox (cbHabilitarAutoarchivado, cbPreguntar) y dos botones (Aceptar, Cancelar) y por otro lado la extensión:

ThisAddin.vb

Imports System.Runtime.InteropServices
Imports System.Runtime.InteropServices
Public Class ThisAddIn
    Private menuBar As Office.CommandBar
    Private newMenuBar As Office.CommandBarPopup
    Private buttonOne As Office.CommandBarButton
    Private menuTag As String = "A unique tag"

    Dim frecuencia_archivado As Integer 'Cada X tiempo se ejecuta
    Dim preguntar_archivado As Integer '0 no pregunta, 1 pregunta antes de archivar
    Dim elementos_anteriores As Integer 'Eliminar anteriores a X


Continuación de ThisAddin.vb

    Dim autoarchivado_habilitado As Integer '0 deshabilitado, 1 pregunta
    Dim formato_tiempo As Integer '0-Meses/1-Semanas/1-Dias
    Dim nombre_pst As String

    Private Sub ThisAddIn_Shutdown(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Shutdown
        'RemoveMenubar()
    End Sub

    Private Sub ThisAddIn_Startup() Handles Me.Startup
        'Conexion con la aplicación Outlook
        Dim olApp As Outlook.Application
        olApp = CreateObject("Outlook.Application")

        'Variables de configuración
        If System.IO.File.Exists(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\Microsoft\Outlook\AutoArchiveByDate.cfg") = False Then 'Si no existe el archivo de configuracion lo crea
            Dim fichero_w As New System.IO.StreamWriter(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\Microsoft\Outlook\AutoArchiveByDate.cfg")
            fichero_w.WriteLine("1,1,0,69,0,1")
            fichero_w.Close()

        End If
        Dim fichero_r As New System.IO.StreamReader(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\Microsoft\Outlook\AutoArchiveByDate.cfg")
        Dim contenido_fichero() As String = fichero_r.ReadLine.Split(",")
        fichero_r.Close()

        autoarchivado_habilitado = contenido_fichero(0) '0 deshabilitado, 1 pregunta
        frecuencia_archivado = contenido_fichero(1) 'Cada X tiempo se ejecuta
        preguntar_archivado = contenido_fichero(2) '0 no pregunta, 1 pregunta antes de archivar
        elementos_anteriores = contenido_fichero(3) 'Eliminar anteriores a X
        formato_tiempo= contenido_fichero(4) '0-Meses/1-Semanas/1-Dias
        nombre_pst = Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\Microsoft\Outlook\archive" & olApp.Session.CurrentProfileName.ToString & My.Computer.Clock.LocalTime.Year & ".pst"     'El nombre del PST sera formato archiveNombrePerfilAño.pst
        Dim version_office As String = olApp.Version.Split(".")(0) & "." & olApp.Version.Split(".")(1)

        'Variable donde se guardan los datos de configuración de outlook
        Dim cadena_registro As String = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & version_office & "\Outlook\Preferences"
        Dim cadena_pst As String = "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\" & olApp.Session.CurrentProfileName.ToString & "\0a0d020000000000c000000000000046"

        'Habilita/Deshabilita el archivado
        My.Computer.Registry.SetValue(cadena_registro, "DoAging", autoarchivado_habilitado)

        'Establece la frecuencia
        My.Computer.Registry.SetValue(cadena_registro, "EveryDays", frecuencia_archivado)

        'Preguntar o no preguntar antes de archivar
        My.Computer.Registry.SetValue(cadena_registro, "PromptForAging", preguntar_archivado)

        'Elementos anteriores a
        My.Computer.Registry.SetValue(cadena_registro, "ArchivePeriod", elementos_anteriores)
        My.Computer.Registry.SetValue(cadena_registro, "ArchiveGranularity", formato_tiempo)

        'Establece el nombre de la PST
        My.Computer.Registry.SetValue(cadena_pst, "001" & Chr(90 + olApp.Version.Split(".")(0)) & "0324", nombre_pst)

        RemoveMenubar()
        AddMenuBar()
    End Sub

    Private Sub AddMenuBar()
        Try
            menuBar = Application.ActiveExplorer().CommandBars.ActiveMenuBar
            newMenuBar = menuBar.Controls.Add( _
                Office.MsoControlType.msoControlPopup, _
                Temporary:=False)
            If newMenuBar IsNot Nothing Then
                newMenuBar.Caption = "AutoArchiveByDate"
                newMenuBar.Tag = menuTag
                buttonOne = newMenuBar.Controls.Add( _
                    Office.MsoControlType.msoControlButton, _
                    Before:=1, Temporary:=True)

                With buttonOne
                    .Style = Office.MsoButtonStyle.msoButtonIconAndCaption
                    .Caption = "Configurar"
                    .FaceId = 65
                    .Tag = "c123"
                End With

                AddHandler buttonOne.Click, AddressOf ButtonOne_Click
                newMenuBar.Visible = True
            End If
        Catch Ex As Exception
            MsgBox(Ex.Message)
        End Try
    End Sub

    Public Sub ButtonOne_Click(ByVal buttonControl As Office. _
    CommandBarButton, ByRef Cancel As Boolean)
        Dim formulario As New Form1
        formulario.Show()

    End Sub

    Private Sub RemoveMenubar()
        Try
            ' If the menu already exists, remove it.
            Dim foundMenu As Office.CommandBarPopup = _
                Application.ActiveExplorer().CommandBars.ActiveMenuBar. _
                FindControl(Office.MsoControlType.msoControlPopup, _
                System.Type.Missing, menuTag, True, True)
            If foundMenu IsNot Nothing Then
                foundMenu.Delete(True)
            End If
        Catch Ex As Exception
            MsgBox(Ex.Message)
        End Try
    End Sub

End Class

Form1.vb

Public Class Form1

    Private Sub Cancelar_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Cancelar.Click
        Me.Close()
    End Sub

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Dim fichero_r As New System.IO.StreamReader(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\Microsoft\Outlook\AutoArchiveByDate.cfg")
        Dim contenido_fichero() As String = fichero_r.ReadLine.Split(",")
        fichero_r.Close()

        Dim autoarchivado_habilitado As String = contenido_fichero(0) '0 deshabilitado, 1 pregunta
        Dim frecuencia_archivado As String = contenido_fichero(1) 'Cada X tiempo se ejecuta
        Dim preguntar_archivado As String = contenido_fichero(2) '0 no pregunta, 1 pregunta antes de archivar
        Dim elementos_anteriores As String = contenido_fichero(3) 'Eliminar anteriores a X
        Dim formato_tiempo As String = contenido_fichero(4) '0-Meses/1-Semanas/1-Dias

        If autoarchivado_habilitado = 1 Then
            cbHabilitarAutoarchivado.Checked = True
        End If
        nFrecuencia.Value = frecuencia_archivado
        If preguntar_archivado = 1 Then
            cbPreguntar.Checked = True
        End If
        nAnteriores.Value = elementos_anteriores
        cbFormatoTiempo.SelectedIndex = formato_tiempo

    End Sub

    Private Sub Aceptar_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Aceptar.Click
        'Guarda las preferencias
        Dim preferencias As String
        If cbHabilitarAutoarchivado.Checked = True Then
            preferencias = "1,"
        Else
            preferencias = "0,"
        End If
        preferencias &= nFrecuencia.Value & ","
        If cbPreguntar.Checked = True Then
            preferencias &= "1,"
        Else
            preferencias &= "0,"
        End If
        preferencias &= nAnteriores.Value & "," & cbFormatoTiempo.SelectedIndex

        Dim fichero_w As New System.IO.StreamWriter(Environment.GetFolderPath(Environment.SpecialFolder.LocalApplicationData) & "\Microsoft\Outlook\AutoArchiveByDate.cfg")
        fichero_w.WriteLine(preferencias)
        fichero_w.Close()
        MsgBox("Debe reiniciar Microsoft Outlook para cargar que los cambios tengan efecto")
        Me.Close()
    End Sub
End Class

Acerca de Miguel Díaz

Informático, enamorado de la programación, diseño Web y el deporte.
Categorías: Outlook, Programación, Proyectos, Servidores, Utilidades, Windows. Etiquetas: , , , , , .

Un comentario en Autoarchivado por fecha en Outlook 2007 automaticamente mediante una extensión

  1. Me ha sido muy util, estaba buscando algo asi por que en mi empresa son 20 empleados y tratar de configurarles el outlook anualmente o ir tanteando los ordenadores para el espacio de las pst es muy costoso de hacer,con esto ya me olvido. No cambies nada.

Deja un comentario

Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *