VBA MsgBox customized to display data in tabular format _ (Data arranged in straight rows and columns)

Option Explicit

Public Enum SPACING
    eSmall = 1&
    eMedium = 3&
    eLarge = 5&
End Enum

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If
    
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrW" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
    Private Declare PtrSafe Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As LongPtr) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function GetBkColor Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
    Private Declare PtrSafe Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
    Private Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
    Private Declare PtrSafe Function SafeArrayGetDim Lib "oleaut32.dll" (psa() As Any) As Long
    Private Declare PtrSafe Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsW" (ByVal hDC As LongPtr, lpMetrics As TEXTMETRIC) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As InitCommonControlsEx) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
    Private Declare Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal Clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr) As LongPtr
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As LongPtr) As LongPtr
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare Function GetBkColor Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextW" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
    Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
    Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
    Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (psa() As Any) As Long
    Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsW" (ByVal hDC As LongPtr, lpMetrics As TEXTMETRIC) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Type InitCommonControlsEx
   Size As Long
   ICC As Long
End Type

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Private Type TEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFist4Byes As Long
    tmSecond4Byes As Long
    tmCharSet As Byte
End Type

Private Type PAINTSTRUCT
    hDC As LongPtr
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0& To 31&) As Byte
End Type

Private Type LVCOLUMNA
    mask As Long
    fmt As Long
    cx As Long
    pszText As String
    cchTextMax As Long
    iSubItem As Long
    iImage As Long
    iOrder  As Long
    cxMin  As Long
    cxDefault  As Long
    cxIdeal  As Long
End Type

Const WIN32_IE = &H501
Private Type LVITEMA
    mask As Long
    iItem As Long
    iSubItem As Long
    state As Long
    stateMask As Long
    pszText As String
    cchTextMax As Long
    iImage As Long
    lParam As Long
    #If (WIN32_IE >= &H300) Then
        iIndent As Long
        iGroupId As Long
        cColumns As Long
        puColumns As LongPtr
    #End If
End Type

Dim vArray() As Variant
Dim bArrayIsExcelRange As Boolean
Dim sSmallDescription As String
Dim lTextColor As Long
Dim eSpacing As SPACING

Dim bSubclassed As Boolean
Dim ButtonsArray() As LongPtr
Dim hCBTHook As LongPtr, hLView As LongPtr, hEdit As LongPtr, hBrush As LongPtr




'_______________________________________ Public Routine ________________________________________________

Public Sub BuildTabFormat( _
    DataArray() As Variant, _
    Optional ByVal IsArrayExcelRange As Boolean, _
    Optional ByVal TableDescription As String, _
    Optional ByVal TextColor As Long = -1, _
    Optional ByVal SpaceBetweenCols As SPACING = eMedium _
)

    Const WH_CBT = 5&
    
    If SafeArrayGetDim(DataArray) = 0 Then
        MsgBox "Table array non-initialized.", vbCritical, "Error!"
        End
    End If
    
    vArray = DataArray
    bArrayIsExcelRange = IsArrayExcelRange
    sSmallDescription = TableDescription
    lTextColor = TextColor
    eSpacing = SpaceBetweenCols
    
    If hCBTHook = NULL_PTR Then
        hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, NULL_PTR, GetCurrentThreadId)
    End If
        
End Sub



'_______________________________________ Private Routines ________________________________________________

Private Function HookProc( _
    ByVal idHook As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr _
) As LongPtr

    Const HC_ACTION = 0&, HCBT_ACTIVATE = 5&
    Dim sBuffer As String * 256&, lRet As Long
    Dim hPrompt As LongPtr
 
    If idHook < HC_ACTION Then
        HookProc = CallNextHookEx(hCBTHook, idHook, wParam, lParam)
        Exit Function
    End If
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sBuffer, 256&)
        If VBA.Left(sBuffer, lRet) = "#32770" Then
            hPrompt = GetDlgItem(wParam, &HFFFF&)
            Call SetWindowText(hPrompt, StrPtr(vbNullString))
            Call MakeTable(wParam, vArray)
            Call UnhookWindowsHookEx(hCBTHook)
            hCBTHook = NULL_PTR
            'Debug.Print "CBT Hook released."
            If bSubclassed = False Then
                bSubclassed = True
                Call SetProp(Application.hwnd, StrPtr("MsgBox"), wParam)
                Call SetWindowSubclass(wParam, WinProcAddr, wParam)
            End If
        End If
    End If

End Function

Private Sub MakeTable(ByVal hwnd As LongPtr, ar() As Variant)

    Const ICC_LISTVIEW_CLASSES = &H1
    Const WC_LISTVIEW = "SysListView32"
    Const LVS_REPORT = &H1
    Const LVS_NOCOLUMNHEADER = &H4000
    Const LVM_FIRST = &H1000
    Const LVM_SETBKCOLOR = (LVM_FIRST + 1&)
    Const LVM_SETTEXTCOLOR = (LVM_FIRST + 36&)
    Const LVM_SETTEXTBKCOLOR = (LVM_FIRST + 38&)
    Const LVM_APPROXIMATEVIEWRECT = (LVM_FIRST + 64&)
    Const LVM_GETITEMRECT = (LVM_FIRST + 14&)
    Const ES_MULTILINE = &H4
    Const ES_READONLY = &H800&
    Const ES_AUTOVSCROLL = &H40
    Const CW_USEDEFAULT = &H80000000
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE = &H10000000
    Const WM_GETFONT = &H31
    Const WM_SETFONT = &H30
    Const COLOR_WINDOW = 5&
    Const SWP_NOMOVE = &H2
    Const SWP_SHOWWINDOW = &H40

    Dim tIccex As InitCommonControlsEx
    Dim tPromptRect As RECT, tItemRect As RECT
    Dim tPt As POINTAPI
    Dim lWidth As Long, lHeight As Long
    Dim Row As Long, Col As Long
    Dim lIconWith As Long
    Dim lBkColor As Long
    Dim lRet As Long
    Dim hPrompt As LongPtr, hFont As LongPtr
    
    With tIccex
        .Size = LenB(tIccex)
        .ICC = ICC_LISTVIEW_CLASSES
    End With
    Call InitCommonControlsEx(tIccex)
    hPrompt = GetDlgItem(hwnd, &HFFFF&)
    Call GetWindowRect(hPrompt, tPromptRect)
    tPt.X = tPromptRect.Left: tPt.Y = tPromptRect.Top
    Call ScreenToClient(hwnd, tPt)
    If IconExists(hwnd) = False Then
        lIconWith = 24&
    End If
    hLView = CreateWindowEx(0&, StrPtr(WC_LISTVIEW), StrPtr("MyLView"), _
             WS_CHILD + WS_VISIBLE + LVS_REPORT + LVS_NOCOLUMNHEADER, _
             tPt.X + lIconWith, tPt.Y, CW_USEDEFAULT, CW_USEDEFAULT, hwnd, NULL_PTR, _
             GetModuleHandle(StrPtr(vbNullString)), ByVal 0&)
    If Len(sSmallDescription) Then
        hFont = SendMessage(hPrompt, WM_GETFONT, NULL_PTR, ByVal 0&)
        hEdit = CreateWindowEx(0&, StrPtr("Edit"), StrPtr(sSmallDescription), _
                WS_CHILD + WS_VISIBLE + ES_MULTILINE + ES_READONLY + ES_AUTOVSCROLL, _
                tPt.X + lIconWith, tPt.Y, CW_USEDEFAULT, CW_USEDEFAULT, hwnd, NULL_PTR, _
                GetModuleHandle(StrPtr(vbNullString)), ByVal 0&)
        Call SetProp(Application.hwnd, StrPtr("Edit"), hEdit)
        Call SetWindowSubclass(hEdit, WinProcAddr, hEdit)
        Call SendMessage(hEdit, WM_SETFONT, hFont, True)
    End If
    Call SetProp(Application.hwnd, StrPtr("ListView"), hLView)
    Call SetWindowSubclass(hLView, WinProcAddr, hLView)
    Call DestroyWindow(hPrompt)
    Call TranslateColor(GetSysColor(COLOR_WINDOW), NULL_PTR, lBkColor)
    Call SendMessage(hLView, LVM_SETBKCOLOR, NULL_PTR, ByVal lBkColor)
    Call SendMessage(hLView, LVM_SETTEXTBKCOLOR, NULL_PTR, ByVal lBkColor)
    Call SendMessage(hLView, LVM_SETTEXTCOLOR, NULL_PTR, ByVal lTextColor)
    Call AddColums(hLView, UBound(ar, 2&))
    For Row = LBound(ar, 1&) + (-CLng(Not bArrayIsExcelRange) Mod 2&) To UBound(ar, 1&)
        For Col = LBound(ar, 2&) + (-CLng(Not bArrayIsExcelRange) Mod 2&) To UBound(ar, 2&)
            Call AddTableEntries(hLView, Row, Col, CStr(ar(Row, Col)))
        Next Col
    Next Row
    lRet = SendMessage(hLView, LVM_APPROXIMATEVIEWRECT, -1&, ByVal 0&)
    If loword(lRet) Then lWidth = loword(lRet)
    If lWidth < 250& Then lWidth = 250&
    If lWidth > 650& Then lWidth = 650&
    If hiword(lRet) Then lHeight = hiword(lRet)
    If lHeight > 500& Then lHeight = 500&
    Call SendMessage(hLView, LVM_GETITEMRECT, 1&, tItemRect)
    Call SetWindowPos(hLView, NULL_PTR, 0&, 0&, lWidth, lHeight, SWP_SHOWWINDOW + SWP_NOMOVE)
    Call AdjustWindowsRects(hLView)

End Sub

Private Function IconExists(ByVal hwnd As LongPtr) As Boolean

    Const GW_CHILD = 5&, GW_HWNDNEXT = 2&
    Const GWL_STYLE = (-16&), SS_ICON = &H3&
    
    Dim sBuffer As String * 256&, lRet As Long
    Dim hChild As LongPtr, lStyle As Long
    
    hChild = GetNextWindow(hwnd, GW_CHILD)
    Do While hChild
        lRet = GetClassName(hChild, sBuffer, 256&)
            If VBA.Left(sBuffer, lRet) = "Static" Then
            lStyle = CLng(GetWindowLong(hChild, GWL_STYLE))
            If lStyle And SS_ICON Then
                IconExists = True
            End If
        End If
        hChild = GetNextWindow(hChild, GW_HWNDNEXT)
    Loop

End Function

Private Sub AdjustWindowsRects(ByVal hwnd As LongPtr)

    Const MSFTEDIT_CLASS = "RichEdit50W"
    Const WM_USER = &H400
    Const CW_USEDEFAULT = &H80000000
    Const EM_SETTARGETDEVICE = WM_USER + 72&
    Const ES_MULTILINE = &H4
    Const ES_READONLY = &H800&
    Const ES_AUTOVSCROLL = &H40
    Const EM_GETLINECOUNT = &HBA
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE = &H10000000
    Const WS_BORDER = &H800000
    Const WM_GETFONT = &H31
    Const WM_SETFONT = &H30
    Const GW_CHILD = 5&
    Const GW_HWNDNEXT = 2&
    Const SM_CXSCREEN = 0&
    Const SM_CYSCREEN = 1&
    Const COLOR_BTNFACE = 15&
    Const SWP_NOSIZE = &H1
    Const SWP_NOMOVE = &H2
    Const SWP_NOZORDER = &H4
    Const SWP_NOACTIVATE = &H10


    Dim p1 As POINTAPI, p2 As POINTAPI, p3 As POINTAPI, p4 As POINTAPI, p5 As POINTAPI, p6 As POINTAPI
    Dim tMsgBoxRect As RECT, tLVRect As RECT, tButtonRect As RECT, tTextRect As RECT
    Dim tm As TEXTMETRIC
    Dim sBuffer As String * 256, lRet As Long
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim n As Long, lBkColor As Long, lNumberLines As Long, lEditHeight As Long
    Dim hMsgBox As LongPtr, hButton As LongPtr, hwndChild As LongPtr
    Dim hLib As LongPtr, hTempRichEdit As LongPtr
    Dim hFont As LongPtr, hDC As LongPtr

    hMsgBox = GetParent(hwnd)
    Call GetWindowRect(hwnd, tLVRect)
    With tLVRect
        p1.X = .Left: p1.Y = .Top
        p2.X = .Right: p2.Y = .Bottom
    End With
    Call ScreenToClient(hMsgBox, p1)
    Call ScreenToClient(hMsgBox, p2)

    If Len(sSmallDescription) Then
        hLib = LoadLibrary(StrPtr("Msftedit.dll"))
        If hLib Then
            hTempRichEdit = CreateWindowEx(0&, StrPtr(MSFTEDIT_CLASS), StrPtr(sSmallDescription), _
                WS_CHILD + WS_VISIBLE + ES_MULTILINE + ES_READONLY + ES_AUTOVSCROLL + WS_BORDER, _
                CW_USEDEFAULT, CW_USEDEFAULT, tLVRect.Right - tLVRect.Left, 0&, GetParent(hwnd), NULL_PTR, _
                GetModuleHandle(StrPtr(vbNullString)), ByVal 0&)
            hFont = SendMessage(hEdit, WM_GETFONT, NULL_PTR, ByVal 0&)
            hDC = GetDC(hTempRichEdit)
            Call GetTextMetrics(hDC, tm)
            Call ReleaseDC(hTempRichEdit, hDC)
            Call SendMessage(hTempRichEdit, WM_SETFONT, hFont, True)
            Call SendMessage(hTempRichEdit, EM_SETTARGETDEVICE, NULL_PTR, ByVal 1&)
            lNumberLines = SendMessage(hTempRichEdit, EM_GETLINECOUNT, NULL_PTR, ByVal 0&)
            If lNumberLines >= 1& Then
                lEditHeight = tm.tmHeight * lNumberLines
                Call SetWindowPos(hTempRichEdit, NULL_PTR, 0&, 0&, _
                     tLVRect.Right - tLVRect.Left, lEditHeight, SWP_NOACTIVATE + SWP_NOZORDER + SWP_NOMOVE)
                Call SetWindowPos(hEdit, NULL_PTR, 0&, 0&, _
                     tLVRect.Right - tLVRect.Left, lEditHeight, SWP_NOACTIVATE + SWP_NOZORDER + SWP_NOMOVE)
                Call DestroyWindow(hTempRichEdit)
                Call SetWindowPos(hwnd, NULL_PTR, p1.X, p1.Y + lEditHeight + IIf(bArrayIsExcelRange, 0&, 20&), _
                     0&, 0&, SWP_NOACTIVATE + SWP_NOZORDER + SWP_NOSIZE)
            End If
        End If
    End If

    hwndChild = GetNextWindow(hMsgBox, GW_CHILD)
    Do While hwndChild
        lRet = GetClassName(hwndChild, sBuffer, 256&)
        If VBA.Left(sBuffer, lRet) = "Button" Then
            n = n + 1&
            ReDim Preserve ButtonsArray(n)
            ButtonsArray(n) = hwndChild
            Call GetWindowRect(hwndChild, tButtonRect)
            With tButtonRect
                .Bottom = .Bottom
                p3.X = .Left: p3.Y = .Top
                p4.X = .Right: p4.Y = .Bottom '
            End With
            Call ScreenToClient(hMsgBox, p3)
            Call ScreenToClient(hMsgBox, p4)
            Call SetWindowPos(hwndChild, NULL_PTR, p2.X - ((p4.X - p3.X) + (n Mod 2& * 10&)) * (n), _
                 lEditHeight + p2.Y + (p4.Y - p3.Y) * 2&, 0&, 0&, _
                 SWP_NOACTIVATE + SWP_NOZORDER + SWP_NOSIZE)
            If n = 1& Then
                hButton = hwndChild
                Call TranslateColor(GetSysColor(COLOR_BTNFACE), NULL_PTR, lBkColor)
                hBrush = CreateSolidBrush(lBkColor)
            End If
        End If
        hwndChild = GetNextWindow(hwndChild, GW_HWNDNEXT)
    Loop

    Call GetWindowRect(hButton, tButtonRect)
    With tButtonRect
        p5.X = .Top: p5.Y = .Bottom
        p6.X = .Left: p6.Y = .Right
    End With
    Call ScreenToClient(hMsgBox, p5)
    Call ScreenToClient(hMsgBox, p6)
    lWidth = p2.X + 50&
    lHeight = p5.Y + (p4.Y - p3.Y) * 2.3
    lLeft = (GetSystemMetrics(SM_CXSCREEN) - lWidth) / 2&
    lTop = (GetSystemMetrics(SM_CYSCREEN) - lHeight) / 2&
    Call SetWindowPos(hMsgBox, NULL_PTR, lLeft, lTop, lWidth, lHeight, SWP_NOACTIVATE + SWP_NOZORDER)

End Sub

Private Sub AddColums( _
    ByVal hwnd As LongPtr, _
    ByVal nColumns As Long _
)

    Const LVM_FIRST = &H1000, LVM_INSERTCOLUMN = (LVM_FIRST + 27&)
    Dim lvcol As LVCOLUMNA, i As Long
    For i = 0& To nColumns - 1&
        Call SendMessage(hwnd, LVM_INSERTCOLUMN, 1&, lvcol)
    Next i
End Sub

Private Sub AddTableEntries( _
    ByVal hwnd As LongPtr, _
    ByVal Row As Long, _
    ByVal Col As Long, _
    ByVal Text As String _
)

    Const LVM_FIRST = &H1000, LVM_GETITEMCOUNT = (LVM_FIRST + 4&)
    Const LVM_INSERTITEM = (LVM_FIRST + 7&), LVM_SETITEM = (LVM_FIRST + 6&)
    Const LVM_SETCOLUMNWIDTH = (LVM_FIRST + 30&)
    Const LVIF_TEXT As Long = &H1, LVSCW_AUTOSIZE As Long = -1&
 
    Static tLvItem As LVITEMA
    Static lPrevRow As Long
    Dim lSpacing As Long

    With tLvItem
        If lPrevRow <> Row Then
            .iItem = SendMessage(hwnd, LVM_GETITEMCOUNT, NULL_PTR, ByVal 0&)
        End If
        Select Case True
            Case eSpacing = eSmall
                lSpacing = 2&
            Case eSpacing = eMedium
                lSpacing = 15&
            Case eSpacing = eLarge
                lSpacing = 50&
        End Select
        .iSubItem = Col - 1&
        .mask = LVIF_TEXT
        .cchTextMax = Len(Text) & String(lSpacing, " ")
        .pszText = Text & String(lSpacing, " ")
    End With
    If lPrevRow <> Row Then
        Call SendMessage(hwnd, LVM_INSERTITEM, NULL_PTR, tLvItem)
    Else
        Call SendMessage(hwnd, LVM_SETITEM, NULL_PTR, tLvItem)
    End If
    Call SendMessage(hLView, LVM_SETCOLUMNWIDTH, Col - 1&, ByVal LVSCW_AUTOSIZE)
    lPrevRow = Row

End Sub

Private Function DefWinProc( _
    ByVal hwnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr, _
    ByVal uIdSubclass As LongPtr, _
    ByVal This As LongPtr _
) As LongPtr

    Const WM_LBUTTONDOWN = &H201, WM_RBUTTONDOWN = &H204, WM_ERASEBKGND = &H14
    Const WM_PAINT = &HF, WM_DESTROY = &H2
    
    Dim tWinRect As RECT, tButtonRect As RECT, tPt As POINTAPI
    Dim tPS As PAINTSTRUCT, Button As Variant
    
    Select Case True
        Case uIdSubclass = GetProp(Application.hwnd, StrPtr("ListView"))
            If wMsg = WM_LBUTTONDOWN Then
                Exit Function
            End If
        Case uIdSubclass = GetProp(Application.hwnd, StrPtr("Edit"))
            If wMsg = WM_RBUTTONDOWN Or wMsg = WM_LBUTTONDOWN Then
                Exit Function
            End If
        Case Else
            If wMsg = WM_PAINT Then
                Call BeginPaint(hwnd, tPS)
                    For Each Button In ButtonsArray
                        Call GetWindowRect(Button, tButtonRect)
                        tPt.X = tButtonRect.Left: tPt.Y = tButtonRect.Top
                        Call ScreenToClient(hwnd, tPt)
                    Next
                    Call GetWindowRect(hwnd, tWinRect)
                    tWinRect.Left = 0&
                    tWinRect.Top = tPt.Y - 15&
                    Call FillRect(tPS.hDC, tWinRect, hBrush)
                Call EndPaint(hwnd, tPS)
            End If
            If wMsg = WM_ERASEBKGND Then
                Exit Function
            End If
    End Select
    If wMsg = WM_DESTROY Then
        Call DeleteObject(hBrush): hBrush = NULL_PTR
        Call RemoveWindowSubclass(hwnd, WinProcAddr, ByVal uIdSubclass)
         bSubclassed = False
        'Debug.Print "Window : "; hwnd; " UnSublclassed."
    End If
 
    DefWinProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)

End Function

#If Win64 Then
    Private Function WinProcAddr() As LongLong
        WinProcAddr = VBA.CLngLng(AddressOf DefWinProc)
    #Else
    Private Function WinProcAddr() As Long
        WinProcAddr = VBA.CLng(AddressOf DefWinProc)
    #End If
End Function

Private Function hiword(ByVal DWord As Long) As Long
    hiword = (DWord And &HFFFF0000) / &H10000
End Function

Private Function loword(ByVal DWord As Long) As Long
    loword = (DWord And &HFFFF&)
End Function

Option Explicit

Sub Example1()

    'Data taken from medium-size range.
    Dim vTable() As Variant
    Dim sTableDescription As String
    
    vTable = Range("A1:C20")
    
    sTableDescription = "This is an example of a medium-sized data set." & vbNewLine & _
    "taken from an excel range and displayed in a tabular format."
    
    Call BuildTabFormat( _
        DataArray:=vTable, _
        IsArrayExcelRange:=True, _
        TableDescription:=sTableDescription _
    )
    
    MsgBox String(1024&, vbKeyTab), vbOKCancel + vbInformation

End Sub

Sub Example2()

    'Data taken from larger size range.
    Dim vTable() As Variant
    Dim sTableDescription As String
    
    vTable = Range("A1:H46")
    
    sTableDescription = "This is an example of a large-sized data set" & _
    "taken from an excel range and displayed in a tabular format." & vbNewLine & _
    "The Tabular data automatically provides scrollbars for navigating the entire data."
    
    Call BuildTabFormat( _
        DataArray:=vTable, _
        IsArrayExcelRange:=True, _
        TableDescription:=sTableDescription, _
        TextColor:=vbRed _
    )
    
    MsgBox String(1024&, vbKeyTab), vbOKCancel + vbExclamation

End Sub

Sub Example3()

    'Data taken from array.
    Dim vTable(7, 3) As Variant
    Dim sTableDescription As String

    vTable(1, 1) = "Name"
    vTable(1, 2) = "Country"
    vTable(1, 3) = "Date Of Birth"
    
    vTable(2, 1) = "====="
    vTable(2, 2) = "======"
    vTable(2, 3) = "========="
   
    vTable(4, 1) = "Amrita Patel"
    vTable(4, 2) = "India"
    vTable(4, 3) = "11/12/1980"
    
    vTable(5, 1) = "John Smith"
    vTable(5, 2) = "United States of America"
    vTable(5, 3) = "19/12/1978"
    
    vTable(6, 1) = "Ahmet Sherif"
    vTable(6, 2) = "Indonesia"
    vTable(6, 3) = "02/12/1988"
    
    vTable(7, 1) = "Ayman Agamy"
    vTable(7, 2) = "Egypt"
    vTable(7, 3) = "30/12/1970"

    sTableDescription = "This is an example of data taken from a 7 x 3 vba array."
    
    Call BuildTabFormat( _
        DataArray:=vTable, _
        IsArrayExcelRange:=False, _
        TableDescription:=sTableDescription, _
        SpaceBetweenCols:=eMedium _
    )

    MsgBox String(1024, vbKeyTab), vbAbortRetryIgnore

End Sub