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.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
Sub CopyRangeToPlainTextOutlook() Dim rCell As Range Dim rCol As Range Dim aMax() As Long Dim lCol 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) If IsNumeric(rCell.Value) Or IsDate(rCell.Value) Then sOutput = sOutput & Space(aMax(lCol) - Len(sTemp)) & sTemp & Space(2) Else sOutput = sOutput & sTemp & Space(aMax(lCol) - Len(sTemp) + 2) End If Next rCell sOutput = RTrim(sOutput) & vbNewLine End If Next rRow doClip.SetText sOutput doClip.PutInClipboard End If End Sub |
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.
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:
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
[…] Dim rCell As Range Dim rCol As… [full post] Dick Kusleika Daily Dose of Excel general 0 0 0 0 0 […]