1Option Explicit On
2Option Strict On
3
4Imports System
5Imports EnvDTE
6Imports System.Diagnostics
7Imports System.Windows.Forms
8Imports System.Text.RegularExpressions
9
10''' <summary>

11''' copies the selected code to the clipboard in HTML format using 

12''' a relatively simple RTF to HTML Regex conversion

13''' </summary>

14''' <remarks>

15''' Jeff Atwood

16''' http://www.codinghorror.com

17''' Version 04/07/2006

18''' </remarks>

19Public Module FormatToHtml
20
21    Private Const _CodeFontName As String = "Monospace"
22    Private Const _CodeFontSize As String = "10pt"
23    Private Const _CodeFontLegacySize As Integer = -1
24    Private Const _CodeBackgroundColor As String = "white"
25    Private Const _CodeForegroundColor As String = "Black"
26    Private Const _TabSpaces As Integer = 4
27    Private Const _RemoveExcessIndentation As Boolean = True
28    Private _n As String = Environment.NewLine
29
30    ''' <description>

31    ''' format RTF to modern HTML

32    ''' </description>

33    Public Sub Modern()
34        PerformRtfConversion(False, True)
35    End Sub
36
37    ''' <description>

38    ''' format RTF to modern HTML, leaving only plain text in the clipboard

39    ''' </description>

40    Public Sub ModernText()
41        PerformRtfConversion(True, True)
42    End Sub
43
44    ''' <description>

45    ''' format RTF to legacy HTML

46    ''' </description>

47    Public Sub Legacy()
48        PerformRtfConversion(False, False)
49    End Sub
50
51    ''' <description>

52    ''' format RTF to legacy HTML, leaving only plain text in the clipboard

53    ''' </description>

54    Public Sub LegacyText()
55        PerformRtfConversion(True, False)
56    End Sub
57
58    Private Sub PerformRtfConversion(ByVal asTextOnly As Boolean, ByVal useModernHtml As Boolean)
59        If Not SelectionToClipboard() Then Return
60
61        '-- retrieve text and rtf from clipboard

62        GetClipboard(DataFormats.Text)
63        Dim text As String = Convert.ToString(_ClipboardObj)
64        GetClipboard(DataFormats.Rtf)
65        Dim rtf As String = Convert.ToString(_ClipboardObj)
66
67        If _RemoveExcessIndentation Then text = RemoveTextIndents(text)
68
69        Dim html As String = RtfToHtml(rtf, useModernHtml)
70        If Not useModernHtml Then
71            html = ConvertSpanToFont(html)
72        End If
73
74        If asTextOnly Then
75            SetClipboardHtml(html, html)
76        Else
77            SetClipboardHtml(html, text)
78        End If
79
80    End Sub
81
82    Private Function RemoveTextIndents(ByVal text As String) As String
83        Dim min As Integer = GetMinimumTextIndent(text)
84        If min = 0 Then
85            Return text
86        Else
87            Return Regex.Replace(text, "^\s{" & min & "}", "", RegexOptions.Multiline)
88        End If
89    End Function
90#Region "  Clipboard"   ...
91
92
93    Private _ClipboardObj As Object
94    Private _ClipboardText As String
95    Private _ClipboardFormat As String = DataFormats.Text
96    Private _RetryCount As Integer = 0
97    Private Const _RetryWaitMs As Integer = 250
98    Private Const _RetryMax As Integer = 10
99
100    '-- this is necessary because we can't get to the clipboard from

101    '-- the macro space directly due to threading issues

102    Private Sub GetClipboard(ByVal format As String)
103        _ClipboardFormat = format
104        _RetryCount = 0
105        Dim t As New Threading.Thread(AddressOf GetClipboardPrivate)
106        t.ApartmentState = Threading.ApartmentState.STA
107        t.Start()
108        t.Join()
109    End Sub
110
111    Private Sub GetClipboardPrivate()
112        _ClipboardObj = Nothing
113        Dim d As IDataObject
114        Try
115            d = Clipboard.GetDataObject()
116        Catch ex As System.Runtime.InteropServices.ExternalException
117            '-- we have to do this because Word may still have the

118            '-- clipboard locked until it shuts down..

119            _RetryCount += 1
120            If _RetryCount <= _RetryMax Then
121                Threading.Thread.Sleep(_RetryWaitMs)
122                GetClipboardPrivate()
123            End If
124            GetClipboardPrivate()
125        End Try
126        If d Is Nothing Then Return
127        _ClipboardObj = d.GetData(_ClipboardFormat)
128    End Sub
129
130    '-- this is necessary because we can't get to the clipboard from

131    '-- the macro space directly due to threading issues

132    Private Sub SetClipboardHtml(ByVal html As String, ByVal text As String)
133        _ClipboardObj = MakeClipboardHtmlFragment(html)
134        _ClipboardText = text
135        Dim t As New Threading.Thread(AddressOf SetClipboardHtmlPrivate)
136        t.ApartmentState = Threading.ApartmentState.STA
137        t.Start()
138        t.Join()
139    End Sub
140
141    Private Sub SetClipboardHtmlPrivate()
142        Dim d As New DataObject
143        d.SetData(DataFormats.Text, _ClipboardText)
144        d.SetData(DataFormats.Html, Convert.ToString(_ClipboardObj))
145        Clipboard.SetDataObject(d, True)
146    End Sub
147
148    '-- Helper routine to build a properly-formatted clipboard HTML fragment.

149    '-- http://mail.localplanet.co.uk/Blogs/stuart/archive/0001/01/01/OneNoteInsertHyperlink.aspx

150    Private Function MakeClipboardHtmlFragment(ByVal html As String) As String
151
152        Const Version As String = "Version:1.0" & vbCrLf
153        Const StartHTML As String = "StartHTML:"
154        Const EndHTML As String = "EndHTML:"
155        Const StartFragment As String = "StartFragment:"
156        Const EndFragment As String = "EndFragment:"
157        Const DocType As String = " "
158        Const HTMLIntro As String = " "
159        Const HTMLExtro As String = ""
160        Const NumberLengthAndCR As Integer = 10
161
162        ' Let the compiler determine the description length.

163        Dim DescriptionLength As Integer = Version.Length + StartHTML.Length + _
164            EndHTML.Length + StartFragment.Length + _
165            EndFragment.Length + 4 * NumberLengthAndCR
166        Dim Description As String
167        Dim StartHTMLIndex, EndHTMLIndex, StartFragmentIndex, EndFragmentIndex As Integer
168        '-- The HTML clipboard format is defined by using byte positions in the 

169        '-- entire block where HTML text and fragments start and end. These positions are written in

170        '-- a description. Unfortunately the positions depend on the length of the description but 

171        '-- the description may change with varying positions.

172        '-- To solve this dilemma the offsets are converted into fixed length strings,

173        '-- which makes it possible to know the description length in advance.

174        StartHTMLIndex = DescriptionLength
175        StartFragmentIndex = StartHTMLIndex + DocType.Length + HTMLIntro.Length
176        EndFragmentIndex = StartFragmentIndex + html.Length
177        EndHTMLIndex = EndFragmentIndex + HTMLExtro.Length
178
179        Dim sb As New System.Text.StringBuilder(Version)
180        With sb
181            .Append(StartHTML)
182            .Append(StartHTMLIndex.ToString.PadLeft(8, "0"c))
183            .Append(_n)
184            .Append(EndHTML)
185            .Append(EndHTMLIndex.ToString.PadLeft(8, "0"c))
186            .Append(_n)
187            .Append(StartFragment)
188            .Append(StartFragmentIndex.ToString.PadLeft(8, "0"c))
189            .Append(_n)
190            .Append(EndFragment)
191            .Append(EndFragmentIndex.ToString.PadLeft(8, "0"c))
192            .Append(_n)
193            .Append(DocType)
194            .Append(HTMLIntro)
195            .Append(html)
196            .Append(HTMLExtro)
197        End With
198        Return sb.ToString
199    End Function
200
201    Private Function SelectionToClipboard() As Boolean
202        '-- Check that something is selected, and copy it to the clipboard

203        If DTE.ActiveDocument Is Nothing Then Return False
204        Dim selection As TextSelection = CType(DTE.ActiveDocument.Selection(), TextSelection)
205        If selection.Text = "" Then Return False
206        selection.Copy()
207        Return True
208    End Function
209#End Region
210#Region "  Rtf To Html"   ...
211
212
213    Private Function ConvertSpanToFont(ByVal html As String) As String
214        html = Regex.Replace(html, "<span\s+style='color:([^']+)'>", "<font color='$1'>")
215        html = html.Replace("</span>", "</font>")
216        Return html
217    End Function
218
219    Private Function GetColorName(ByVal cr As Drawing.Color) As String
220        For i As Integer = 1 To 167
221            Dim kc As Drawing.KnownColor = CType(i, Drawing.KnownColor)
222            If Drawing.Color.FromKnownColor(kc).ToArgb() = cr.ToArgb() Then
223                If Not Drawing.Color.FromKnownColor(kc).IsSystemColor Then
224                    Return Drawing.Color.FromKnownColor(kc).Name
225                End If
226            End If
227        Next
228        Return ""
229    End Function
230
231    Private Function HtmlColor(ByVal m As Match) As String
232        Dim c As Drawing.Color
233        Dim name As String
234        c = Drawing.Color.FromArgb( _
235            Convert.ToInt32(m.Groups("red").Value), _
236            Convert.ToInt32(m.Groups("green").Value), _
237            Convert.ToInt32(m.Groups("blue").Value))
238        name = GetColorName(c)
239        If name.Length > 0 Then
240            Return name
241        Else
242            Return "#" & c.ToArgb.ToString("x").Substring(2)
243        End If
244    End Function
245
246    Private Function HtmlSpaces(Optional ByVal spaces As Integer = 0) As String
247        Dim sb As New Text.StringBuilder
248        For i As Integer = 1 To spaces
249            sb.Append(" ")
250        Next
251        Return sb.ToString
252    End Function
253
254    Private Function GetMinimumTextIndent(ByVal text As String) As Integer
255        '-- if any lines start with a non-space, indent level is automatically zero

256        If Regex.IsMatch(text, "\r\n\S") Then
257            Return 0
258        End If
259
260        Dim shortestIndent As Integer = Integer.MaxValue
261        Dim spaces As Integer = 0
262
263        '-- get the shortest series of spaces at the beginning of a line

264        For Each m As Match In Regex.Matches(text, "^.*?(?<Spaces>(\s)+)", RegexOptions.Multiline)
265            spaces = m.Groups("Spaces").Value.Length
266            If spaces < shortestIndent Then
267                shortestIndent = spaces
268            End If
269        Next
270
271        If shortestIndent = Integer.MaxValue Then
272            Return 0
273        Else
274            Return shortestIndent
275        End If
276    End Function
277
278    Private Function GetMinimumHtmlIndent(ByVal html As String) As Integer
279        '-- if any lines start with a non-space, indent level is zero

280        If Regex.IsMatch(html, "<br/>\r\n(?! |</span)") Then
281            Return 0
282        End If
283
284        Dim shortestIndent As Integer = Integer.MaxValue
285        Dim spaces As Integer = 0
286
287        '-- get the shortest series of   at the beginning of a line

288        For Each m As Match In Regex.Matches(html, "^.*?(?<Spaces>( )+)", RegexOptions.Multiline)
289            spaces = m.Groups("Spaces").Value.Length \ 6
290            If spaces < shortestIndent Then
291                shortestIndent = spaces
292            End If
293        Next
294
295        If shortestIndent = Integer.MaxValue Then
296            Return 0
297        Else
298            Return shortestIndent
299        End If
300    End Function
301
302    Private Function RtfToHtml(ByVal rtf As String, ByVal useModernHtml As Boolean) As String
303        Dim TabSpaceHtml As String = HtmlSpaces(_TabSpaces)
304
305        '-- remove line breaks

306        rtf = Regex.Replace(rtf, "[\n\r\f]", "")
307
308        '-- parse RTF color table

309        Dim ColorTable As New Collections.Hashtable
310        Dim i As Integer = 0
311        ColorTable.Add(i, _CodeForegroundColor)
312        i += 1
313        For Each m As Match In Regex.Matches(rtf, "\\red(?<red>\d+)\\green(?<green>\d+)\\blue(?<blue>\d+);")
314            ColorTable.Add(i, HtmlColor(m))
315            i += 1
316        Next
317
318        '-- remove header and footer RTF tags

319        rtf = Regex.Replace(rtf, "{\\rtf1[^\s]+\s", "")
320        rtf = Regex.Replace(rtf, "}$", "")
321        rtf = Regex.Replace(rtf, "\\deff0{\\fonttbl{\\f\d+[^}]+}}", "")
322        rtf = Regex.Replace(rtf, "{\\colortbl;(\\red\d+\\green\d+\\blue\d+;)+}", "")
323
324        '-- fix escaped C# brackets

325        rtf = Regex.Replace(rtf, "\\{", "{")
326        rtf = Regex.Replace(rtf, "\\}", "}")
327
328        '-- fix doubled backslashes

329        rtf = Regex.Replace(rtf, "\\\\", "\")
330
331        '-- replace any HTML-specific characters
332        rtf = Web.HttpUtility.HtmlEncode(rtf)
333
334        '-- map non-standard characters (from \'e4 to ä) /Sire 2006-04-05
335        Dim hex As String = ""
336        Dim dec As Integer = 0
337        For Each m As Match In Regex.Matches(rtf, "\\'(?<hex>[a-f0-9][a-f0-9])")
338            hex = m.Groups("hex").Value
339            dec = Integer.Parse(hex, System.Globalization.NumberStyles.HexNumber)
340            rtf = Regex.Replace(rtf, "\\'" & hex, "&#" & dec & ";")
341        Next
342
343        '-- map bold
344        rtf = Regex.Replace(rtf, "{\\b\s([^}]+?)}", "<b>$1</b>")
345
346        '-- convert RTF tags to HTML equivalents
347        rtf = Regex.Replace(rtf, "\\tab\s", TabSpaceHtml)
348        rtf = Regex.Replace(rtf, "\\par\s", "<br/>" & _n)
349
350        '-- remove unmapped RTF tags
351        rtf = Regex.Replace(rtf, "\\fs\d+\s", "")
352        rtf = Regex.Replace(rtf, "(\\cf\d+)\\cb\d+\\highlight\d+\s", "$1 ")
353        rtf = Regex.Replace(rtf, "\\cb\d+\\highlight\d+\s", "")
354
355        '-- map foreground color RTF tags
356        For Each de As Collections.DictionaryEntry In ColorTable
357            rtf = Regex.Replace(rtf, "\\cf" & Convert.ToString(de.Key) & "\s", _
358                "</span><span style='color:" & Convert.ToString(de.Value) & "'>")
359        Next
360
361        '-- fix up orphaned spans at start and end
362        rtf = Regex.Replace(rtf, "(^.*?)</span>", "$1")
363        rtf = rtf & "</span>"
364
365        '-- convert remaining spaces to HTML spaces
366        rtf = Regex.Replace(rtf, "  ", "  ")
367
368        '-- add block wrapper
369        If useModernHtml Then
370            rtf = "<div style='" & _
371                "font-family:" & _CodeFontName & "; " & _
372                "font-size: " & _CodeFontSize & "; " & _
373                "background-color: " & _CodeBackgroundColor & ";'>" & _n & _
374                rtf & _n & _
375                "</div>" & _n
376        Else
377            rtf = "<p><font face='" & _CodeFontName & "' size='" & _CodeFontLegacySize & "'>" & _n & _
378                rtf & _n & _
379                "</font></p>" & _n
380        End If
381
382        '-- strip unnecessary initial indents for heavily indented code
383        If _RemoveExcessIndentation Then
384            Dim min As Integer = GetMinimumHtmlIndent(rtf)
385            If min > 0 Then
386                rtf = Regex.Replace(rtf, "(^.*?)(" & HtmlSpaces(min) & ")", _
387                    "$1", RegexOptions.Multiline)

388            End If
389        End If
390
391        Return rtf
392    End Function
393#End Region
394
395End Module

import this file as a macro (alt+f11 to get to macro explorer).
then highlight the code and use macro explorer to activate it