The macro below is NOT mine and I don't know who to give credit to, but thank you for the starting point.
It works for all all but messages containing Bullets or Number list (Outline) formatting.
Is there a better VBA macro to automatically replace ^p with ^l when using Bullets and Number Lists in Outlook 2010 under Win 7
If not, what must be changed/modified below to allow for Bullets and Number lists?
i.e.
- indent 1
- Indent 2
- Etc
' ****************MACRO***************
Public FormatKey As Boolean
Sub Application_Startup() ' This routine runs when Outlook is started
FormatKey = True ' Reformatting is enabled when Outlook is started
End Sub
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objItem As Object
Dim objInsp As Outlook.Inspector
Dim objNS As Outlook.NameSpace
Set objOL = Application
' Add reference to Word library
' in VBA Editor, Tools, References
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
On Error Resume Next
Set objNS = objOL.Session
'Reference the current Outlook item
Set objItem = Application.ActiveInspector.CurrentItem
If (Not objItem Is Nothing And FormatKey) Then
If objItem.Class = olMail Then
Set objInsp = objItem.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
objWord.Selection.WholeStory
Set objSel = objWord.Selection
objSel.Find.ClearFormatting
objSel.Find.Replacement.ClearFormatting
With objSel.Find
.Text = "^p"
.Replacement.Text = "^l"
' .Forward = True
.Forward = False
.Wrap = wdFindContinue
' .Format = True
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
objSel.Find.Execute Replace:=wdReplaceAll
End If
End If
End If
If (1 = 2) Then ' Remove this and uncomment next
' If (objItem.BodyFormat = olFormatHTML And FormatKey) Then ' message format is HTML and reformatting is enabled
xstr = objItem.HTMLBody ' Get the body of the message into xstr
''''''' FOR DEBUGGING - Uncomment this to view original HTML code generated by Outlook ''''''''
' Open "c:\temp\OutlookHTMLoriginal.txt" For Output As #1
' Print #1, xstr
' Close #1
''''''' END DEBUGGING CODE ''''''''
match1 = "<o></o>" ' strings of stuff Outlook generates for paragraph tag
Lmatch1 = Len(match1)
L = Len(xstr)
j = 0 ' input string counter
ystr = ""
Do While (j <= L) ' examine each character in body of message
j = j + 1
If (j <= L - (Lmatch1 - 1) And Mid(xstr, j, Lmatch1) = match1) Then ' A paragraph tag was found
ystr = ystr & "" ' change it to a break tag
j = j + (Lmatch1 - 1) ' skip checking the rest of the paragraph tag
Else
ystr = ystr & Mid(xstr, j, 1) ' Just copy the input character to output string
End If
Loop
''''''' FOR DEBUGGING - Uncomment this to view reformatted HTML code ''''''''
' Open "c:\temp\OutlookHTMLreformatted.txt" For Output As #1
' Print #1, ystr
' Close #1
''''''' END DEBUGGING CODE ''''''''
objItem.HTMLBody = ystr ' replace message body with the modified string
End If
Set objItem = Nothing
Set objWord = Nothing
Set objSel = Nothing
Set objInsp = Nothing
End Sub
Sub ToggleFormatKey() ' Calling this routine toggles reformatting on or off.
If (FormatKey) Then
FormatKey = False
' CreateObject("WScript.Shell").Popup "Send reformatting is DISABLED", 1, "Microsoft Outlook", 64 + 4096
i = MsgBox("Send reformatting is DISABLED", vbOKOnly)
Else
FormatKey = True
' CreateObject("WScript.Shell").Popup "Send reformatting is ENABLED", 1, "Microsoft Outlook", 64 + 4096
i = MsgBox("Send reformatting is ENABLED", vbOKOnly)
End If
End Sub