2009-05-04

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

Publicar un comentario