Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
Hi all,
As you probably know, displaying text data arranged/aligned in straight columns inside the standard vba MsgBox is extremely difficult. I personally have never seen this done before... Calculating the msgbox font size is a nightmare.
Here, I am using a few api-based workarounds to achieve that effect.
Essencially, you simply call the BuildTabFormat routine right before displaying the standard vba MsgBox and voila! ... Very easy to use!
The BuildTabFormat routine takes arguments for displaying the tabular data (either from an excel range or from a 2D array) and an argument to display a small optional description text ... The routine can also allow for optionally changing the text color and the spacing between the columns.
Another cool thing is that when the data is too large, the MsgBox automatically diplays vertical and/or horizonatl scrollbars so the user can navigate the entire data.
Please, note that although the code subclasses the MsgBox, It should be safe and stable.
I hope you find this useful.
Download:
TabularVBAMsgBox.xlsm
1- API code in a Standard Module:
2- Code Usage examples:
Testd only in Excel 2016 x64 Windows10 x64
As you probably know, displaying text data arranged/aligned in straight columns inside the standard vba MsgBox is extremely difficult. I personally have never seen this done before... Calculating the msgbox font size is a nightmare.
Here, I am using a few api-based workarounds to achieve that effect.
Essencially, you simply call the BuildTabFormat routine right before displaying the standard vba MsgBox and voila! ... Very easy to use!
The BuildTabFormat routine takes arguments for displaying the tabular data (either from an excel range or from a 2D array) and an argument to display a small optional description text ... The routine can also allow for optionally changing the text color and the spacing between the columns.
Another cool thing is that when the data is too large, the MsgBox automatically diplays vertical and/or horizonatl scrollbars so the user can navigate the entire data.
Please, note that although the code subclasses the MsgBox, It should be safe and stable.
I hope you find this useful.
Download:
TabularVBAMsgBox.xlsm
1- API code in a Standard Module:
VBA Code:
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 Function2- Code Usage examples:
VBA Code:
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 SubTestd only in Excel 2016 x64 Windows10 x64
