Option Explicit
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type HDITEM
mask As Long
cxy As Long
pszText As String
hbm As Long
cchTextMax As Long
fmt As Long
lParam As Long
iImage As Long
iOrder As Long
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) 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 CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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 DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private hHook As LongPtr, lPrevButtonProc As LongPtr, hNameManager As LongPtr, hButton As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private hHook As Long, lPrevButtonProc As Long, hNameManager As Long, hButton As Long
#End If
Private vSettingsValues(0 To 8, 2) As Variant
Private bSettingsUpdated As Boolean
Public Sub Save_Name_Manager_Settings()
Const WH_CBT = 5
Dim oSh As Worksheet, oCurrentSheet As Worksheet
bSettingsUpdated = False
Call UnhookWindowsHookEx(hHook)
hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
Application.Dialogs(xlDialogNameManager).Show
Call UnhookWindowsHookEx(hHook)
If bSettingsUpdated Then
If Not SheetExists("Name_Manager_Settings") Then
Set oCurrentSheet = ActiveSheet
Application.EnableEvents = False
Set oSh = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
oSh.Name = "Name_Manager_Settings"
oCurrentSheet.Activate
Application.EnableEvents = True
End If
With ThisWorkbook.Sheets("Name_Manager_Settings")
.Range("A1:I2").Value = Transpose2DArray(vSettingsValues)
.Columns("A:I").EntireColumn.AutoFit
.Range("A1:I1").Font.Bold = True
End With
'ThisWorkbook.Save '<==== Save the changes to Disk to preserve the new settings.
MsgBox "Name Manager Settings Saved in Sheet: 'Name_Manager_Settings' .", vbInformation
End If
End Sub
#If Win64 Then
Private Function HookProc(ByVal lCode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
Dim hListViewParent As LongLong
#Else
Private Function HookProc(ByVal lCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hListViewParent As Long
#End If
Const MAX_PATH = 260
Const WS_CHILD = &H40000000
Const WS_VISIBLE As Long = &H10000000
Const GWL_WNDPROC As Long = -4
Const HCBT_ACTIVATE = 5
Const HC_ACTION = 0
Dim tRect As RECT
Dim sClassName As String * MAX_PATH, lBuff As Long, lRet As Long
If lCode < HC_ACTION Then
HookProc = CallNextHookEx(hHook, lCode, wParam, lParam)
Exit Function
End If
If lCode = HCBT_ACTIVATE Then
lBuff = MAX_PATH
lRet = GetClassName(wParam, sClassName, lBuff)
If Left(sClassName, lRet) = "bosa_sdm_XL9" Then
Call UnhookWindowsHookEx(hHook)
hNameManager = wParam
hListViewParent = FindWindowEx(wParam, 0, "XLLVP", vbNullString)
Call GetClientRect(wParam, tRect)
hButton = CreateWindowEx(0, "Button", "Save Settings", WS_CHILD + WS_VISIBLE, _
tRect.Left + 300, tRect.Top + 5, 100, 25, wParam, 0, GetModuleHandle(vbNullString), 0)
lPrevButtonProc = SetWindowLong(hButton, GWL_WNDPROC, AddressOf ButtonProc)
End If
End If
Call CallNextHookEx(hHook, lCode, wParam, lParam)
End Function
#If Win64 Then
Private Function ButtonProc(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
Private Function ButtonProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Const WM_LBUTTONUP = &H202
Const WM_SYSCOMMAND = &H112
Const SC_CLOSE = &HF060&
Const GWL_WNDPROC As Long = -4
Select Case Msg
Case WM_LBUTTONUP
Call GetNameManagerSettings
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevButtonProc)
Call DestroyWindow(hwnd)
Call PostMessage(hNameManager, WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
bSettingsUpdated = True
End Select
ButtonProc = CallWindowProc(lPrevButtonProc, hwnd, Msg, wParam, ByVal lParam)
End Function
Private Sub GetNameManagerSettings()
Const HDM_FIRST = &H1200
Const HDM_GETITEMCOUNT = (HDM_FIRST + 0)
Const HDM_GETITEMA = (HDM_FIRST + 3)
Const HDM_GETITEM = HDM_GETITEMA
Const HDF_STRING = &H4000
Const HDI_TEXT = 2
Const LVM_FIRST = &H1000
Const LVM_GETCOLUMNWIDTH = LVM_FIRST + 29
Const MAX_PATH = 260
#If Win64 Then
Dim hwnd As LongLong, hParent As LongLong
Dim lColumn As LongLong, lCols As LongLong, lRet As LongLong
#Else
Dim hwnd As Long, hParent As Long
Dim lColumn As Long, lCols As Long, lRet As Long
#End If
Dim tHd As HDITEM
Dim tWinRect As RECT
Dim sBuffer As String * MAX_PATH
hwnd = FindWindowEx(hNameManager, 0, "XLLVP", vbNullString)
hParent = FindWindowEx(hwnd, 0, "SysListView32", vbNullString)
hwnd = FindWindowEx(hParent, 0, "SysHeader32", vbNullString)
If hParent Then
lCols = SendMessage(hwnd, HDM_GETITEMCOUNT, 0, 0)
Call GetWindowRect(hNameManager, tWinRect)
With tWinRect
vSettingsValues(0, 1) = "Left": vSettingsValues(0, 2) = .Left
vSettingsValues(1, 1) = "Top": vSettingsValues(1, 2) = .Top
vSettingsValues(2, 1) = "Width": vSettingsValues(2, 2) = .Right - .Left
vSettingsValues(3, 1) = "Height": vSettingsValues(3, 2) = .Bottom - .Top
End With
For lColumn = 0 To lCols - 1
Call SendMessage(hParent, LVM_GETCOLUMNWIDTH, CLng(lColumn), ByVal 0)
With tHd
.mask = HDI_TEXT
.cchTextMax = MAX_PATH
.pszText = sBuffer
.fmt = HDF_STRING
End With
lRet = SendMessage(hwnd, HDM_GETITEM, CLng(lColumn), tHd)
If lRet Then
vSettingsValues(CLng(lColumn) + 4, 1) = StripNulls(Left(tHd.pszText, MAX_PATH))
vSettingsValues(CLng(lColumn) + 4, 2) = SendMessage(hParent, LVM_GETCOLUMNWIDTH, CLng(lColumn), ByVal 0)
End If
Next
End If
End Sub
Private Function StripNulls(Str As String) As String
If InStr(Str, Chr(0)) Then
Str = Left(Str, InStr(Str, Chr(0)) - 1)
End If
StripNulls = Str
End Function
Private Function SheetExists(ByVal SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not CBool(Sheets(SheetName) Is Nothing)
On Error GoTo 0
End Function
Private Function Transpose2DArray(InputArray As Variant) As Variant
Dim X As Long, yUbound As Long
Dim Y As Long, xUbound As Long
Dim vTempArray As Variant
xUbound = UBound(InputArray, 2)
yUbound = UBound(InputArray, 1)
ReDim vTempArray(1 To xUbound, 0 To yUbound)
For X = 1 To xUbound
For Y = 0 To yUbound
vTempArray(X, Y) = InputArray(Y, X)
Next Y
Next X
Transpose2DArray = vTempArray
End Function