Posting an HTML table in a forum thread

[JBeaucaire]

UPDATE: - Thanks to sktneer and Doc.AElstein for tweaks making this tool more universally compatible.
=========

Sometimes you merely want to show visually something you're discussing in the thread, an excerpt from one of your sheets... without posting an entire workbook.

Data Range

	A	B	C	D	E	F	G
1	[TRC]	[TKWSN]
2	1st Retirees	Blue Man Group
3	1st Benefits	101st Irregulars
4
5						1st Pick	Result
6						[TRC]	1st Retirees

This is how I do it. I store all this code in my Personal.xlsb file and created a button on my ribbon to the CopyRngToHTML which actually calls the other stuff.

Option Explicit

#If VBA7 Then 'The hash symbols represent a preprocessor command, which are commands that are processed prior to compilation
Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#Else
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#End If

Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096

Sub CopyRngToHTML()
Dim DataObj As Object, strTable As String
    Set DataObj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Application.CutCopyMode = False
    strTable = RngToHTML(Selection)
    ClipBoard_SetData (strTable)
End Sub


Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long
 
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)         'Allocate moveable global memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)                   'Lock the block to get a far pointer to this memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)           'Copy the string to this global memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then                     'Unlock the memory.
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If
   If OpenClipboard(0&) = 0 Then                                'Open the Clipboard to copy data to.
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If
   X = EmptyClipboard()                                         'Clear the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)       'Copy the data to the Clipboard.
 
OutOfHere2:
   If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard."
End Function

Private Function RngToHTML(rInput As Range, Optional bHeaders As Boolean = True) As String
   Dim rRow As Range, rCell As Range, sReturn As String, strAux As String, strColor As String
   Dim strAlign As String
   sReturn = "[Table=""class: grid""]"
   If bHeaders Then
      sReturn = sReturn & "[tr][td] [/td]"
      For Each rCell In rInput.Rows(1).Cells
         sReturn = sReturn & "[td][CENTER][b]" & ColLetters(rCell.Column) & "[/b][/CENTER][/td]"
      Next rCell
      sReturn = sReturn & "[/tr]"
   End If
   For Each rRow In rInput.Rows
      sReturn = sReturn & vbNewLine & "[tr]"
      If bHeaders Then
         sReturn = sReturn & "[td][CENTER][b]" & rRow.Row & "[/b][/CENTER][/td]"
      End If
      For Each rCell In rRow.Cells
         Select Case VarType(rCell.Value2)
            Case 8          'String
               strAlign = "LEFT"
            Case 10, 11     'Error or Boolean
               strAlign = "CENTER"
            Case Else       'Others
               strAlign = "RIGHT"
         End Select
         strAux = Right("000000" & Hex(rCell.Font.Color), 6)
         strColor = "#" & Right(strAux, 2) & Mid(strAux, 3, 2) & Left(strAux, 2)
         sReturn = sReturn & "[td][COLOR=""" & strColor & """][" & strAlign & "]" & _
                   rCell.Text & "[/" & strAlign & "][/COLOR][/td]"
      Next rCell
      sReturn = sReturn & "[/tr]" & vbNewLine
   Next rRow
   sReturn = sReturn & "[/table]"
   RngToHTML = "Data Range" & vbNewLine & sReturn
End Function

Private Function ColLetters(lCol As Long) As String
    With ActiveSheet.Columns(lCol)
        ColLetters = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
    End With
End Function 

Not remembering if they were important or not, I made a note of the TOOLS > REFERENCES I have selected in my system and they are:

[x] Visual Basic for Applications
[x] Microsoft Excel 14.0 Object Library
[x] OLE Automation
[x] Microsoft Office 14.0 Object Library

[JBeaucaire]

I amended post #1 to include the current references I have active in my VBEditor.

==============
How I create a PERSONAL.XLSB for the first time:
1) Press the Record Macro button

2) In the initial popup window select:
Store Macro in: Personal Macro Workbook

3) Click OK, then click a few random cells, then stop the macro recorder.

4) Open the VBEditor and you will have a new PERSONAL.XLS (or .XLSB) project available. Open the Module1 in that VBAproject.

5) Erase the recorded content, paste in the macros you're wanting available all the time.

6) CTRL-S to save your changes

7) Exit the VBAeditor and CLOSE Excel. If you are reminded that your Personal workbook has been changed and offer to save changes, DO save them.

8) Reopen Excel and your macros are there.

==============
How I added a button to my ribbon (2010+):
1) Right-click an empty spot anywhere on the current ribbon and select Customize the Ribbon

2) On the right side Customize the ribbon - Main Tabs - Developer

3) Right-click the main tab, I used Developer, and select Add New Group - name it MyTools

4) On the left Choose Commands from - Macros, find your macro and select it, then click the ADD button in the middle

5) Your macro is now on the right in the new MyTools group, right-click on it and select Rename to give it a unique toolbar name and select your icon


==========
ADD a quick access symbol XL 2007 and XL 2010:
1) Right-click in the upper command Tab Bar XL 2007, anywhere on the current ribbon XL 2010 and select customize Quick Access Toolbar

2) On the right side of the Excel Option Dialogue Box that should come up, select in the upper right Dropdown list ,( customize Quick Access Toolbar), For all documents if it is not already selected.

3) On the left upper drop down box ( Choose Commands from) select - Macros, if it is not already selected.

4) The large box below should now show all available Macros. Find your macro and select it, then click the ADD button in the middle

5) Select finally OK below in the main Excel Option Dialogue box.

[Doc.AElstein]

. Hi JBeaucaire,
. As you have deleted many of the posts from yesterday in this thread could I just again
. 1) acknowledge the help from Jan Karel Pieterse:
http://www.jkp-ads.com/articles/apideclarations.asp
. and
. 2) Note the discussed late and Early Binding variation Possibilities:

Please Login or Register  to view this content.

. Thanks
. Alan

[jackluter]

The technique is not helpful to rank the website using HTML use CSS code.

[6StringJazzer]

The technique is not helpful to rank the website using HTML use CSS code.

jackluter, your post has nothing to do with this thread, and doesn't make sense here. Please ensure that your comments are on topic.

[Doc.AElstein]

jac kluter, your post has nothing to do with this thread, and doesn't make sense here.....

He is Jack Clutter ... LOl!!

P.S. I have collected a whole bunch of codes similar to the one discussed here.
These codes are for putting a BB CODE of a table based on a spreadsheet range selection into the clipboard. ( This you can then paste into a forum post , which will produce a Table in the Post after posting which looks like the spreadsheet range and from which you can copy and paste back into a spreadsheet ).
I add to this collection from time to time , and keep the file at this link updated:
“MollyBBCodes.xlsm” https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
________________( Check April 2017 https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9 )

I have also attached the most recent version.

Alan






______ awesome.JPG ____ http://imgur.com/afZlixB

[6StringJazzer]

Sub CopyRngToHTML()
Dim DataObj As Object, strTable As String
    Set DataObj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    Application.CutCopyMode = False
    strTable = RngToHTML(Selection)
    ClipBoard_SetData (strTable)
End Sub 

Jerry--DataObj is declared and set but never referenced. What is it and what kind of object is created in this call?

[shg]

MSForms.DataObject

[Gregor y]

Adding the cell background color to the VBA would be nice too.

[6StringJazzer]

Adding the cell background color to the VBA would be nice too.

Making the following modification to the code will do that:

Please Login or Register  to view this content.

Values as displayed

	A	B	C
1
2		Test Cell
3

[6StringJazzer]

Here is a substantially modified version that shows the correct colors if conditional formatting is applied, as well as incorporating text formatting for values.

Please Login or Register  to view this content.