Outlook Plain Text Tables

I’ve never been quite satisfied with my attempts to paste tables into plain text Outlook emails, so I decided to do it by brute force.

You have to have a reference to the Microsoft 2.0 Forms Library for the clipboard part.

I started by using rCell.Value, but that doesn’t get my formatting (commas, decimal places, etc) in there properly. I went to rCell.Text to get the formatting, but the columns didn’t line up properly. I learned that the font can determine the length of the Text property. I then tried to change the font to a monospace font like Courier, but I was clearly going down a rabbit hole with that thinking. In the end I Trim the Text property and right justify numbers and dates, left justify everything else. I don’t think it’s perfect, but it’s closer than ever before.

2 thoughts on “Outlook Plain Text Tables

  1. Nice code. I get upset sometimes with poor paste handling between Windows’ Applications.
    I just did an improvement: the code recognize if user set left, right or center alignment. In case of other type of alignment or no alignment at all, the behaviour will be the code you wrote:

    Sub CopyRangeToPlainTextOutlookAlignment()
       
        Dim rCell As Range
        Dim rCol As Range
        Dim aMax() As Long
        Dim lCol As Long
        Dim lSpaces As Long
        Dim sOutput As String
        Dim rRow As Range
        Dim doClip As MSForms.DataObject
        Dim sTemp As String
       
        If TypeName(Selection) = “Range” Then
            Set doClip = New MSForms.DataObject
           
            ReDim aMax(1 To Selection.Columns.Count)
           
            For Each rCol In Selection.Columns
                lCol = lCol + 1
                For Each rCell In rCol.Cells
                    If Not rCell.EntireRow.Hidden Then
                        sTemp = Trim(rCell.Text)
                        If Len(sTemp) > aMax(lCol) Then aMax(lCol) = Len(sTemp)
                    End If
                Next rCell
            Next rCol
           
            For Each rRow In Selection.Rows
                If Not rRow.Hidden Then
                    lCol = 0
                    For Each rCell In rRow.Cells
                        lCol = lCol + 1
                        sTemp = Trim(rCell.Text)
                        lSpaces = Len(Space(aMax(lCol) – Len(sTemp)))
                        Select Case rCell.HorizontalAlignment
                            Case xlHAlignCenter
                                sOutput = sOutput & Space(lSpaces 2 + lSpaces Mod 2) & _
                                          sTemp & Space(lSpaces 2) & Space(2)
                            Case xlHAlignLeft
                                sOutput = sOutput & sTemp & Space(lSpaces) & Space(2)
                            Case xlHAlignRight
                                sOutput = sOutput & Space(lSpaces) & sTemp & Space(2)
                            Case Else
                                If IsNumeric(rCell.Value) Or IsDate(rCell.Value) Then
                                    sOutput = sOutput & Space(lSpaces) & sTemp & Space(2)
                                Else
                                    sOutput = sOutput & sTemp & Space(lSpaces + 2)
                                End If
                        End Select
                    Next rCell
                    sOutput = RTrim(sOutput) & vbNewLine
                End If
            Next rRow
           
            doClip.SetText sOutput
            doClip.PutInClipboard
        End If
           
    End Sub


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.