Sign in Subscribe

Add syntax highlighting when pasting code into Outlook 2013

John Westlund

• 5 min read

Full credit goes to avbrand.com this technique. I've made some minor tweaks so it will work if you system is configured with a proxy. Remember you're using a web service (https://tohtml.com) to perform the highlighting -- so if the code is really sensitive this may not be for you.

  1. Enable Macros
  • Click 'File', followed by'Options'
  • Find 'Trust Center', then 'Trust Center Settings'
  • Select the 'Macro Settings' tab
  • Select 'Enable all macros', and click OK.
    • Again, this is not ideal, I'll try and follow up with how to self sign your macro
  1. Enable Developer Mode
  • Right-click the Ribbon and select 'Customize the Ribbon'
  • In the list on the right side, underneath Main Tabs, there should be checkbox labeled Developer. Check box if not already checked.
  • Click OK to close the window.
  1. Open Visual Basic editor
  • Click the 'Developer' tab. To the far right of File
  • Click the 'Visual Basic' button
  1. Add reference to necessary libraries
  • Click the 'Tools' menu, then 'References'
  • Click 'Browse', then type 'FM20.DLL' and press OK
    • This is the Microsoft Forms 2.0 Library
  • Click OK
  1. Time to code
  • Expand the Project pane on the left and double click 'ThisOutlookSession'
  • A blank code window should appear, if not follow the directions on where to paste the contents below.
  • Begin by pasting this code at the top of the file:
Option Explicit
 
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal cbLength As Long)
 
Private m_cfHTMLClipFormat As Long
 
Private Const m_sDescription = _
                  "Version:1.0" & vbCrLf & _
                  "StartHTML:aaaaaaaaaa" & vbCrLf & _
                  "EndHTML:bbbbbbbbbb" & vbCrLf & _
                  "StartFragment:cccccccccc" & vbCrLf & _
                  "EndFragment:dddddddddd" & vbCrLf

Now paste this at the bottom:

Public Sub Pastec()
  PasteCode "c"
End Sub

Public Sub Pastecpp()
  PasteCode "cpp"
End Sub

Public Sub Pasteperl()
  PasteCode "perl"
End Sub

Public Sub Pastepython()
  PasteCode "python"
End Sub

Public Sub Pastehtml()
  PasteCode "html"
End Sub

Public Sub Pastexml()
  PasteCode "xml"
End Sub

Public Sub Pastemysql()
  PasteCode "mysql"
End Sub

Public Sub Pasteshell()
  PasteCode "shell"
End Sub

Public Sub Pastemakefile()
  PasteCode "makefile"
End Sub

Public Sub PasteTeX()
  PasteCode "TeX"
End Sub
 
Private Sub PasteCode(mLanguage As String)
    ' Paste code into the message window.
    Dim req
    Dim URL
    Dim f
    Dim r As String
    Dim e, e2
    Dim origT As String
    
    Debug.Print "Starting Paste Code"
    
    URL = "https://tohtml.com/" & mLanguage & "/"
    
    ' Retrieve text from the clipboard
    Dim fm As MSForms.DataObject
    Set fm = New MSForms.DataObject
    fm.GetFromClipboard
    r = fm.GetText(1) ' Text
    origT = r
    
    If r <> "" Then
        ' Get the code colorized by tohtml.com
        f = "code_src=" & Escape(r)
        f = f & "&Submit=Highlight"
        f = f & "&style=hs"
        f = f & "&type=" & Escape(mLanguage)

        Dim HttpReq As Object
        Set HttpReq = CreateObject("MSXML2.XMLHTTP")
        With HttpReq
         .Open "POST", URL, False
         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
         .Send (f)
         r = .responseText
        End With

        ' Extract the response
        e = InStr(1, r, "<textarea", vbTextCompare)
        e = InStr(e + 1, r, ">", vbTextCompare)
        e2 = InStr(e + 1, r, "</textarea>", vbTextCompare)
        
        If e > 0 And e2 > e Then
            r = Mid(r, e + 1, e2 - e - 1)

            ' Fix the HTML code
            r = Replace(r, "&gt;", ">")
            r = Replace(r, "&lt;", "<")
            r = Replace(r, "&apos;", "'")
            r = Replace(r, "&quot;", """")
            r = Replace(r, "&amp;", "&")
            
            r = Replace(r, "#ffffff", "#f6f8ff", 1, 1, vbTextCompare)
            
            PutHTMLClipboard r, origT
            ' Paste into current message
            On Error GoTo errHandler
            If TypeName(ActiveWindow) = "Inspector" Then
               If ActiveInspector.IsWordMail And ActiveInspector.EditorType = olEditorWord Then
                    ActiveInspector.WordEditor.Application.Selection.Paste
               End If
            End If
        End If
    End If
    
    Debug.Print "Paste Code Complete"
errHandler:  
End Sub
 
Private Function RegisterCF() As Long
   'Register the HTML clipboard format
   If (m_cfHTMLClipFormat = 0) Then
      m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
   End If
   RegisterCF = m_cfHTMLClipFormat  
End Function
 
Private Sub PutHTMLClipboard(sHtmlFragment As String, textVersion As String, Optional sContextStart As String = "<HTML><BODY>", Optional sContextEnd As String = "</BODY></HTML>")
   
   Dim sData As String
   
   If RegisterCF = 0 Then Exit Sub ' If we can't register the clipboard handle, then cancel.
   
   'Add the starting and ending tags for the HTML fragment
   sContextStart = sContextStart & "<!--StartFragment -->"
   sContextEnd = "<!--EndFragment -->" & sContextEnd
   
   'Build the HTML given the description, the fragment and the context. And, replace the offset place holders in the description with values for the offsets of StartHMTL, EndHTML, StartFragment and EndFragment.
   sData = m_sDescription & sContextStart & sHtmlFragment & sContextEnd
   sData = Replace(sData, "aaaaaaaaaa", Format(Len(m_sDescription), "0000000000"))
   sData = Replace(sData, "bbbbbbbbbb", Format(Len(sData), "0000000000"))
   sData = Replace(sData, "cccccccccc", Format(Len(m_sDescription & sContextStart), "0000000000"))
   sData = Replace(sData, "dddddddddd", Format(Len(m_sDescription & sContextStart & sHtmlFragment), "0000000000"))
 
   textVersion = textVersion & Chr(0)
    
   'Add the HTML code to the clipboard
   If CBool(OpenClipboard(0)) Then
   
      Dim hMemHandle As Long, lpData As Long
        If sHtmlFragment <> "" Then
            hMemHandle = GlobalAlloc(0, Len(sData) + 10)
            
            If CBool(hMemHandle) Then
                     
               lpData = GlobalLock(hMemHandle)
               If lpData <> 0 Then
                  CopyMemory ByVal lpData, ByVal sData, Len(sData)
                  GlobalUnlock hMemHandle
                  EmptyClipboard
                  SetClipboardData m_cfHTMLClipFormat, hMemHandle
               End If
            End If
        End If
      
      hMemHandle = GlobalAlloc(0, Len(textVersion) + 10)
      
      If CBool(hMemHandle) Then
         lpData = GlobalLock(hMemHandle)
         If lpData <> 0 Then
            CopyMemory ByVal lpData, ByVal textVersion, Len(textVersion)
            GlobalUnlock hMemHandle
            If sHtmlFragment = "" Then EmptyClipboard
            SetClipboardData 1, hMemHandle
         End If
      End If
   
      Call CloseClipboard
   End If
End Sub
 
Private Function fixZeros(inSt)
    ' Adds a 0 to the front if needed.
    fixZeros = inSt
    If Len(fixZeros) = 1 Then fixZeros = "0" & fixZeros
End Function

Private Function Escape(inTxt)
    ' Escape the text.
    Dim i
    Dim outText
    
    outText = inTxt
    Escape = outText
    
    Escape = Replace(Escape, "%", "%25")
    For i = 1 To 255
        If i = 37 Then
            ' skip %
        ElseIf i >= 65 And i <= 90 Then
            ' A-Z
        ElseIf i >= 97 And i <= 122 Then
            ' a-z
        ElseIf i >= 48 And i <= 57 Then
            ' 0-9
        Else
            Escape = Replace(Escape, Chr(i), "%" & fixZeros(Hex(i)))
        End If
    Next
End Function

The first portion of the above defines functions for each language you might want to highlight -- feel free to add more from the list on http://tohtml.com. Use the values of the entries in the 'Type' combo box (i.e. look at the page source).

For example this would add a function for Cobol:

Public Sub PasteCobol()
    PasteCode "cobol"

To finish up create buttons for the email drafting window:

  1. Open an email compose or reply window.
    • I have had mixed results when the e-mail in embedded in the Outlook window -- "Pop-out" the composition window first.
  • Right-click the Ribbon and select 'Customize the Ribbon'
  • Click 'New Group' in the lower right
  • Rename it to 'Paste Code'
  • On the Left side change the dropdown from 'Popular Commands' to 'Macros'
  • You should now see 'Project1.ThisOutlookSession.PasteXXX', etc.
  • Select the one's you want to easily be able to use and click 'Add'
  • Click Rename and clean up the name, e.g. like 'Paste C++'
  • Click OK
  • Copy some code, and paste it into the email using your new buttons

Sign up for more like this.

Enter your email
Subscribe