Funciones útiles para el Outlook (GTD)

Algunas macros que estoy utilizando; básicamente hay 3 botones:

• "al archivo" --> mueve el correo a la carpeta de archivo
• "ahora no" --> mueve el correo a la carpeta de "pendiente" y crea una tarea relacionada
• "a la espera" --> mueve el correo a la carpeta de "a la espera" prefijando el asunto con el nombre de la persona por la que esperamos

Tengo todo el código en un único módulo:

Attribute VB_Name = "Módulo1"


' ****************************
' ****************************
' **  Botones               **
' ****************************
' ****************************

Public Sub ArchivarMensaje()
   MoverMensajeSeleccionado "Carpetas Personales\Archivo\Proyectos", False
End Sub


Public Sub AhoraNo()
   'MoverMensajeSeleccionado "Carpetas Personales\01 Pendiente", True
   CrearTareaAPartirDeCorreo ("Carpetas Personales\01 Pendiente")
End Sub


Public Sub ALaEspera()
   
   Dim esperandoPor As String
   
   esperandoPor = InputBox("¿esperando por quién?", "Por quien espera este tema?")
   MoverMensajeSeleccionado "Carpetas Personales\02 A la espera", True, "[" & esperandoPor & "] "
   
End Sub




















' ******************************
' ******************************
' **  Funciones principales   **
' ******************************
' ******************************


Private Sub MoverMensajeSeleccionado(carpeta As String, pasarACarpetaDestino As Boolean, Optional concatenaEstoAlPrincipio)

  Dim olApp As Outlook.Application
  Dim olExp As Outlook.Explorer
  Dim olMessage As MailItem
  Dim fldCurrent As Outlook.MAPIFolder
  Dim fldDestino As Outlook.MAPIFolder
  Dim cntSelection As Integer
  Dim i As Integer
  
  
  Set olApp = Outlook.CreateObject("Outlook.Application")
  Set olExp = olApp.ActiveExplorer
  
  
  cntSelection = olExp.Selection.Count
 
  For i = 1 To cntSelection
  
      Set olMessage = olExp.Selection.Item(i)
      Set fldCurrent = olExp.CurrentFolder
      Set fldDestino = GetFolder(carpeta)
  
      'olMessage.ShowCategoriesDialog
  
      
      If Not IsMissing(concatenaEstoAlPrincipio) Then
        olMessage.Subject = concatenaEstoAlPrincipio & " " & olMessage.Subject
        olMessage.Save
      End If
      
      olMessage.Move fldDestino
      
  Next
  
  If pasarACarpetaDestino Then
     Set olExp.CurrentFolder = fldDestino
  End If

End Sub









Public Sub CrearLINKMensaje()
  
  Dim olApp As Outlook.Application
  Dim olExp As Outlook.Explorer
  Dim olMessage As MailItem
  
  Set olApp = Outlook.CreateObject("Outlook.Application")
  Set olExp = olApp.ActiveExplorer
  Set olMessage = olExp.Selection.Item(1)

  
  Dim ClipBoard As String
  
  ClipBoard = "Outlook:" + olMessage.EntryID
  
  Set DataO = New DataObject
  DataO.Clear
  'Data0.SetData DataFormats.HTML, ClipBoard
  DataO.SetText ClipBoard
  DataO.PutInClipboard

End Sub









Private Sub CrearTareaAPartirDeCorreo(carpetaPendientes As String)

  Dim fldDestino As Outlook.MAPIFolder
  Dim olApp As Outlook.Application
  Dim olExp As Outlook.Explorer
  Dim olMessage As MailItem
  Dim olTask As Outlook.TaskItem
  Dim newolMessage As MailItem
  
  Set fldDestino = GetFolder(carpetaPendientes)
  
  Set olApp = Outlook.CreateObject("Outlook.Application")
  Set olExp = olApp.ActiveExplorer
  
  
  
  'El correo (o correos) actualmente seleccionados...
  
  Dim cntSelection As Integer
  cntSelection = olExp.Selection.Count
  
  If (cntSelection = 1) Then
  
  
    '...se mueve a la carpeta de "Pendientes"
    Set olMessage = olExp.Selection.Item(1)
    Set newolMessage = olMessage.Move(fldDestino)
    
    'y se crea una tarea a partir de él a la que se la adjunta el enlace al correo
    Set olTask = olApp.CreateItem(olTaskItem)
  
    'asunto
    olTask.Subject = olMessage.Subject
      
    'contenido
    InsertLinkToMessage olTask, newolMessage
    
    'categorias
    olTask.Categories = olMessage.Categories
    
    olTask.Display
  
  Else
    MsgBox "solo uno, por favor"
  
  End If
  


End Sub



























' ********************************
' ********************************
' **  Utilidades de bajo nivel  **
' ********************************
' ********************************


Private Function GetFolder(strFolderPath As String) As MAPIFolder
  ' folder path needs to be something like
  '   "Public Folders\All Public Folders\Company\Sales"
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim colFolders As Outlook.Folders
  Dim objFolder As Outlook.MAPIFolder
  Dim arrFolders() As String
  Dim i As Long
  On Error Resume Next

  strFolderPath = Replace(strFolderPath, "/", "\")
  arrFolders() = Split(strFolderPath, "\")
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objFolder = objNS.Folders.Item(arrFolders(0))
  If Not objFolder Is Nothing Then
    For i = 1 To UBound(arrFolders)
      Set colFolders = objFolder.Folders
      Set objFolder = Nothing
      Set objFolder = colFolders.Item(arrFolders(i))
      If objFolder Is Nothing Then
        Exit For
      End If
    Next
  End If

  Set GetFolder = objFolder
  Set colFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Function





Private Sub RenombrarTituloSegunCategorias()

  Dim olApp As Outlook.Application
  Dim objCat As Category
  Dim cat As String
  Dim olTask As TaskItem
  
  Set olApp = Outlook.CreateObject("Outlook.Application")
  Set olTask = olApp.ActiveInspector.CurrentItem
  
  categoriasArr = Split(olTask.Categories, ";")
  
  For i = 0 To UBound(categoriasArr)
    cat = categoriasArr(i)
    If Mid(cat, 1, 4) = "Prj:" Then
      olTask.Subject = "[" & Mid(cat, 5) & "] " & olTask.Subject
    End If
  Next

End Sub





Sub InsertLinkToMessage(task As Outlook.TaskItem, msg As Outlook.MailItem)
    
    Dim objInsp As Outlook.Inspector
    ' requires reference to Microsoft Word library
    Dim objDoc As Word.Document
    Dim objSel As Word.Selection
    Dim objParagraph As Word.Paragraph
    
    Dim olAtt As Outlook.Attachment
    Dim strAdjuntos As String
    
    
    strLink = "Outlook:" & msg.EntryID
    strLinkText = "Mensaje original"
    Set objInsp = task.GetInspector
    Set objDoc = objInsp.WordEditor
    Set objSel = objDoc.Windows(1).Selection
    
       
    If msg.BodyFormat <> olFormatPlain Then
        
        ' ¿tiene adjuntos?
        strAdjuntos = ""
        For Each olAtt In msg.Attachments
           strAdjuntos = olAtt.FileName & "; "
        Next
        
        
        objDoc.Range.Text = vbCrLf & _
                  "De: " & msg.SenderName & vbCrLf & _
                  "Asunto: " & msg.Subject & vbCrLf & _
                  "Recibido: " & msg.ReceivedTime & vbCrLf & _
                  "Adjuntos: " & strAdjuntos & vbCrLf & vbCrLf & _
                  msg.Body & vbCrLf
        objDoc.Range.Font.Shrink
        objDoc.Range.Font.Shrink
        objDoc.InlineShapes.AddHorizontalLineStandard objSel.Range
        objSel.Range.Text = vbCrLf & vbCrLf & vfCRLF & vbCrLf & vfCRLF
        'objParagraph = objDoc.Paragraphs.Add(objSel.Range)
        'objParagraph.Range.Text = vbCrLf
        objDoc.Hyperlinks.Add objSel.Range, strLink, _
                              "", "", strLinkText, ""
    Else
        objSel.InsertAfter strLink
    End If
    
    
    Set objInsp = Nothing
    Set objDoc = Nothing
    Set objSel = Nothing
End Sub






Private Function GetMsgDetails(Item As MailItem, Details As String) As String

    If Details <> "" Then
        Details = Details + vbCrLf
    End If
    Details = Details + Item.Subject + vbCrLf
    Details = Details + "Outlook:" + Item.EntryID + vbCrLf

    GetMsgDetails = Details

End Function