'Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
#If Win64 Then
'Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As Long
'Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
'Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
#Else
'Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
'Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
'Private Declare Function CloseClipboard Lib "user32.dll" () As Long
#End If
' Fix for dicky clipboard =================================================
' Thread: https://social.msdn.microsoft.com/Forums/en-US/48e8c30c-24ee-458e-a873-a4e6e13f5926/dataobject-settext-and-putinclipboard-sequence-puts-invalid-data-hex-63-characters-in-clipboard
' Fix: https://msdn.microsoft.com/en-us/library/office/ff192913.aspx?f=255&MSPPError=-2147217396
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
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
' End of Fix for dicky clipboard ==============================================
Sub Clear_Clipboard()
'clear clipboard first
OpenClipboard (0)
EmptyClipboard
CloseClipboard
End Sub
Sub Make_Grid(Optional ByVal generator_setting As Variant) 'must be set as variant to use IsMissing
Dim rngWhole As Range, vGrid As Variant, vWBnms As Variant, vWSnms As Variant
Dim strOutput As String
Dim objData As DataObject
Dim rngFormulas As Range, rngTemp As Range, ar As Range
Dim lngRows As Long
Dim blnHasNames As Boolean
Dim i As Long
Dim FormulasToParse As FormulaSettings
blnHasNames = (ActiveWorkbook.Names.Count > 0)
If IsMissing(generator_setting) Then
FormulasToParse = ThisWorkbook.Worksheets("Settings").Range("A1").Value
Else
FormulasToParse = generator_setting
End If
Clear_Clipboard
On Error Resume Next
If Selection.Count = 1 Then
Set rngWhole = Selection
Else
Set rngWhole = Selection.SpecialCells(xlCellTypeVisible)
End If
On Error GoTo 0
If rngWhole Is Nothing Then Exit Sub
'not efficient for every case but will work!:
Generate_Grid vGrid, rngWhole
If IsEmpty(vGrid) Then Exit Sub 'check to see if max col or max rows exceeded
Set objData = New DataObject
'strOutput = "<b>" & ExcelVersion() & "</b><table width=""" & Application.Lookup(UBound(vGrid, 2), Array(2, 3, 4, 5), Array("30%", "50%", "70%", "90%")) & """ cellpadding=""2.5px"" rules=""all"" style="";background-color: " & TB_BCKGRND_COLOR & ";border: 1px solid;border-collapse: collapse; border-color: " & TB_BORDER_COLOR & """>" '
strOutput = "<b>" & ExcelVersion() & "</b><table cellpadding=""2.5px"" rules=""all"" style="";background-color: " & TB_BCKGRND_COLOR & ";border: 1px solid;border-collapse: collapse; border-color: " & TB_BORDER_COLOR & """>" '
strOutput = strOutput & Grid_2_html(vGrid)
strOutput = strOutput & "</tbody></table><p style=""width:" & Len(rngWhole.Parent.Name) * 0.6 & "em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid " & TB_BORDER_COLOR & ";border-top:none;text-align: center;background-color: " & ROWHDR_BCKGRND_COLOR & ";color: " & ROWHDR_FONT_COLOR & """>" & rngWhole.Parent.Name & "</p><br /><br />" '
On Error Resume Next 'turn off error reporting so next bit doesnt fail
If rngWhole.Count = 1 Then
If rngWhole.HasFormula Then Set rngFormulas = rngWhole
Else
Select Case FormulasToParse
Case AllFormulas
Set rngFormulas = rngWhole.SpecialCells(xlCellTypeFormulas)
Case FirstCell
Set rngFormulas = rngWhole.SpecialCells(xlCellTypeFormulas).Cells(1, 1)
Case FirstCellInColumn
Set rngTemp = rngWhole.SpecialCells(xlCellTypeFormulas)
If Not rngTemp Is Nothing Then
For Each ar In rngTemp.Areas
For i = 1 To ar.Columns.Count
If rngFormulas Is Nothing Then
Set rngFormulas = ar(1, i)
Else
Set rngFormulas = Union(rngFormulas, ar(1, i))
End If
Next i
Next ar
End If
Case NoFormulas
Set rngFormulas = Nothing
Case UserDefined
Set rngFormulas = Application.InputBox("Select cells to include in output", "Select Formula Cells", Type:=8)
'next bit should fix the problem if only a single cell range is selected (should restrict to that single cell):
If rngFormulas.Count > 1 Then Set rngFormulas = rngFormulas.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeFormulas)
Case Else
Set rngFormulas = rngWhole.SpecialCells(xlCellTypeFormulas)
End Select
End If
On Error GoTo 0
Dim cell As Range, rngHasArray As Range, rngNormalFormula As Range
If Not rngFormulas Is Nothing Then
'extract defined names in activeworkbook referenced in formula:
If blnHasNames Then Identify_Used_Names rngFormulas, vWBnms, vWSnms
For Each cell In rngFormulas
'if the cell is merged we only want the first cell in the merged area
If cell.MergeArea.Cells(1).Address(False, False) = cell.Address(False, False) Then
'does the cell have an array formula?
If cell.HasArray Then
'if it is a single cell array formula or a merged cell
If (cell.Address(False, False) = cell.CurrentArray.Address(False, False)) Or (cell.MergeArea.Address(False, False) <> cell.Address(False, False)) Then
If rngHasArray Is Nothing Then
Set rngHasArray = cell
Else
Set rngHasArray = Union(rngHasArray, cell)
End If
'if it is a multiple cell array formula
Else
If rngHasArray Is Nothing Then
Set rngHasArray = cell
Else
If Intersect(rngHasArray, cell.CurrentArray) Is Nothing Then
Set rngHasArray = Union(rngHasArray, cell)
End If
End If
End If
'it is not an array formula
Else
If rngNormalFormula Is Nothing Then
Set rngNormalFormula = cell
Else
Set rngNormalFormula = Union(rngNormalFormula, cell)
End If
End If
End If
Next cell
If Not rngNormalFormula Is Nothing Then _
strOutput = strOutput & "<table width=""85%"" cellpadding=""2.5px"" rules=""all"" style="";border: 2px solid black;border-collapse:collapse;padding: 0.4em;background-color: " & TB_BCKGRND_COLOR & """ ><tr><td style=""padding:6px"" ><b>Worksheet Formulas</b>" _
& MakeFormulaTable(rngNormalFormula) & "</td></tr></table><br />"
If Not rngHasArray Is Nothing Then _
strOutput = strOutput & "<table width=""85%"" cellpadding=""2.5px"" rules=""all"" style="";border: 2px solid black;border-collapse:collapse;padding: 0.4em;background-color: " & TB_BCKGRND_COLOR & """ ><tr><td style=""padding:6px"" ><b>Array Formulas</b>" _
& MakeFormulaTable(rngHasArray, True) & "<b>Entered with Ctrl+Shift+Enter.</b> If entered correctly, Excel will " & _
"surround with curly braces {}." & Chr$(10) & "<b>Note: Do not try and enter the {} manually yourself</b></td></tr></table><br />"
If Not IsEmpty(vWBnms) Then _
strOutput = strOutput & "<table width=""85%"" cellpadding=""2.5px"" rules=""all"" style="";border: 2px solid black;border-collapse:collapse;padding: 0.4em;background-color: " & TB_BCKGRND_COLOR & """ ><tr><td style=""padding:6px"" ><b>Workbook Defined Names</b>" _
& MakeNameTable(vWBnms) & "</td></tr></table><br />"
If Not IsEmpty(vWSnms) Then _
strOutput = strOutput & "<table width=""85%"" cellpadding=""2.5px"" rules=""all"" style="";border: 2px solid black;border-collapse:collapse;padding: 0.4em;background-color: " & TB_BCKGRND_COLOR & """ ><tr><td style=""padding:6px"" ><b>Worksheet Defined Names</b>" _
& MakeNameTable(vWSnms) & "</td></tr></table>"
End If
ClipBoard_SetData (strOutput)
'objData.SetText strOutput
'objData.PutInClipboard
End Sub
Function Grid_2_html(vGrid As Variant) As String
Dim strTemp As String
Dim i As Long, j As Long
'generate first col identifier first:
strTemp = "<colgroup><col width=""25px"" style=""background-color: " & ROWHDR_BCKGRND_COLOR & """ />" '
For i = 2 To UBound(vGrid, 2)
strTemp = strTemp & "<col />" 'iterate thru and generate the rest
Next i
strTemp = strTemp & "</colgroup>" 'close the colgroup tag
For i = 1 To UBound(vGrid, 1)
For j = 1 To UBound(vGrid, 2)
If i = 1 And j = 1 Then
strTemp = strTemp & "<thead><tr style="" background-color: " & COLHDR_BCKGRND_COLOR & ";text-align: center;color: " & ROWHDR_FONT_COLOR & """><th></th>" 'first cell so start html
ElseIf i = 1 Then 'first row (ie column headers)
If j = UBound(vGrid, 2) Then 'ie last column in col hdrs
strTemp = strTemp & "<th>" & vGrid(i, j) & "</th></tr></thead><tbody>"
Else
strTemp = strTemp & "<th>" & vGrid(i, j) & "</th>"
End If
ElseIf j = 1 Then 'first column so row headers
strTemp = strTemp & "<tr ><td style=""color: " & ROWHDR_FONT_COLOR & ";text-align: center;"">" & vGrid(i, j) & "</td>"
Else
If j = UBound(vGrid, 2) Then 'last col
' If IsEmpty(vGrid(i, j)) Then 'if it wasn't part of the cell selection
' strTemp = strTemp & "<td></td></tr>" 'dont apply formats
' Else
strTemp = strTemp & "<td " & AnalyzeCell(Cells(vGrid(i, 1), vGrid(1, j))) & ">" & vGrid(i, j) & "</td></tr>"
' End If
Else
' If IsEmpty(vGrid(i, j)) Then 'if it wasn't part of the cell selection
' strTemp = strTemp & "<td></td>" 'dont apply formats
' Else
strTemp = strTemp & "<td " & AnalyzeCell(Cells(vGrid(i, 1), vGrid(1, j))) & ">" & vGrid(i, j) & "</td>"
' End If
End If
End If
Next j
Next i
Grid_2_html = strTemp
End Function
Function AnalyzeCell(cell As Range) As String
Dim strFormat As String, varVal As Variant
strFormat = "style="""
With cell
If .Font.Bold Then strFormat = strFormat & "font-weight: bold;"
If .HorizontalAlignment = xlRight Then
strFormat = strFormat & "text-align: right;"
ElseIf .HorizontalAlignment = xlCenter Then
strFormat = strFormat & "text-align: center;"
ElseIf .HorizontalAlignment = 1 Then 'And IsNumeric(.Value)
On Error Resume Next
varVal = CLng(.Value)
On Error GoTo 0
If Not IsEmpty(varVal) Then strFormat = strFormat & "text-align: right;"
End If
If .Borders(xlEdgeTop).LineStyle <> xlLineStyleNone Then strFormat = strFormat & "border-top: 1px solid black;"
If .Borders(xlEdgeRight).LineStyle <> xlLineStyleNone Then strFormat = strFormat & "border-right: 1px solid black;"
If .Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then strFormat = strFormat & "border-bottom: 1px solid black;"
If .Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone Then strFormat = strFormat & "border-left: 1px solid black;"
If .Font.Italic Then strFormat = strFormat & "font-style: italic;"
If .Font.Underline <> xlUnderlineStyleNone Then strFormat = strFormat & "text-decoration: underline;"
If .Font.ColorIndex <> -4105 And .Font.ColorIndex <> 1 And .Font.ColorIndex <> xlColorIndexNone Then strFormat = strFormat & "color: #" & StringColorRev(Right("00000" & Hex(.Font.Color), 6)) & ";"
If .Interior.ColorIndex <> xlColorIndexNone Then strFormat = strFormat & "background-color: #" & StringColorRev(Right("000000" & Hex(cell.Interior.Color), 6)) & ";"
End With
strFormat = strFormat & ";"""
AnalyzeCell = strFormat
End Function
Function StringColorRev(s As String) As String
Dim temp As String
temp = Right(s, 2) & Mid(s, 3, 2) & Left(s, 2)
StringColorRev = temp
End Function
Function MakeFormulaTable(r As Range, Optional blnArr As Boolean = False) As String
Dim cell As Range
Dim temp As String
temp = "<table cellpadding=""2.5px"" width=""100%"" rules=""all"" style=""border: 1px solid;text-align:center;background-color: " & _
TB_BCKGRND_COLOR & ";border-collapse: collapse; border-color: " & TB_BORDER_COLOR & _
"""><thead><tr style="" background-color: " & COLHDR_BCKGRND_COLOR & ";color: " & _
ROWHDR_FONT_COLOR & """><th width=""10px"">Cell</th><th style=""text-align:left;padding-left:5px;"">Formula</th></tr></thead><tbody>"
For Each cell In r
'if it is an array formula and it is not in a merged cell we want the currentarray address:
If cell.HasArray And (cell.MergeArea.Address(False, False) = cell.Address(False, False)) Then
temp = temp & "<tr><th width=""10px"" style="" background-color: " & COLHDR_BCKGRND_COLOR & ";color: " & ROWHDR_FONT_COLOR & """>" & _
cell.CurrentArray.Address(False, False) & "</th><td style=""text-align:left"">" & IIf(blnArr, "{", "") & FormatFormula(cell.Formula) & IIf(blnArr, "}", "") & "</td></tr>"
Else
temp = temp & "<tr><th width=""10px"" style="" background-color: " & COLHDR_BCKGRND_COLOR & ";color: " & _
ROWHDR_FONT_COLOR & """>" & cell.Address(False, False) & "</th><td style=""text-align:left"">" & FormatFormula(cell.Formula) & "</td></tr>"
End If
Next cell
temp = temp & "</tbody></table>"
MakeFormulaTable = temp
End Function
Function MakeNameTable(ByRef vNms As Variant) As String
Dim i As Long
Dim temp As String
temp = "<table cellpadding=""2.5px"" width=""100%"" rules=""all"" style=""border: 1px solid;text-align:center;background-color: " & TB_BCKGRND_COLOR & ";border-collapse: collapse; border-color: " & _
TB_BORDER_COLOR & """><thead><tr style="" background-color: " & COLHDR_BCKGRND_COLOR & ";color: " & _
ROWHDR_FONT_COLOR & """><th width=""10px"">Name</th><th style=""text-align:left"">Refers To</th></tr></thead><tbody>"
For i = LBound(vNms) To UBound(vNms)
temp = temp & "<tr><th width=""10px"" style="" background-color: " & COLHDR_BCKGRND_COLOR & ";color: " & ROWHDR_FONT_COLOR & """>" & vNms(i) & _
"</th><td style=""text-align:left"">" & FormatFormula(ActiveWorkbook.Names(vNms(i)).RefersTo) & "</td></tr>"
Next i
temp = temp & "</tbody></table>"
MakeNameTable = temp
End Function
Function ReplaceChar(ByVal s As String) As String
'deals with tricky characters such as > <
ReplaceChar = Replace(Replace(s, ">", ">"), "<", "<")
End Function
Function ExcelVersion() As String
Dim temp As String
On Error Resume Next
Select Case CLng(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
End Select
ExcelVersion = temp
End Function
Function ReplaceSpace(ByVal s As String) As String
'function to replace
Dim b() As Byte
Dim i As Long, lngLB As Long
b = StrConv(s, vbFromUnicode)
lngLB = LBound(b)
For i = UBound(b) To lngLB Step -1
If i > lngLB Then 'if we aren't at the last position
If b(i) = 32 Then 'if it's a space
If b(i - 1) = 32 Then b(i) = 160 'if character before is also a space then change current space to a non-breakign space
End If
End If
Next i
ReplaceSpace = StrConv(b, vbUnicode)
End Function
' Fix for dicky clipboard =================================================
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
' Allocate moveable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
' Clear the Clipboard.
X = EmptyClipboard()
' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
' End of Fix for dicky clipboard =================================================
