Programmatically Resize Name Manager Dialog Box

Greg_M

New Member
Joined
Jan 28, 2017
Messages
11
Hi All,

I use Excel's built-in Name Manager a LOT!

Each time Excel is started, the dimensions, column widths etc. of the Name Manager dialog box are reset to default values which (I suppose!) are stored somewhere. The problem is that these default values are unsuitable for me, and I would like to be able to resize the dialog box programmatically.

I've performed a quick check of registry value changes but have been unable to identify where these settings might be stored.

So, does anyone know how to programmatically resize the Name Manager dialog box using e.g. API calls, registry values, other methods???

Regards,

Greg M

Please note that this item was originally posted on Excel Forum at: Programmatically Resize Name Manager Dialog Box
 
Last edited by a moderator:

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,192
Office Version
  1. 2016
Platform
  1. Windows
Hi Greg,
The "Save Settings" text on the above button is very small
I have modified the first code so that the font in the "save settings" button is borrowed from the Name Manager default font. This is done via GetCurrentObject(hDlgDc, OBJ_FONT).

The idea is to make sure that the font of the custom button is the same as that of its parent NM dialog regardless of the machine display settings. Therefore the custom button font should be the same size as that of all other NM native buttons such as New, Filter, Close etc ... It worked for me as expected and hope it works for you too.

Also, in order to increase the visiblility of the custom button, I have added code to paint its backgound with a yellow brush as welll as change the text color to red.

NameManagerHook_V2.xls

This is how it looked in my testings:







This is the modified (Save settings code) code :
VBA Code:
Option Explicit

Type POINTAPI
    x As Long
    y As Long
End Type

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 Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetCurrentObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal uObjectType As Long) 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 SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hDc As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) 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 ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long

    Private hHook As LongPtr, lPrevButtonProc As LongPtr, hNameManager  As LongPtr, hButton As LongPtr, lPrevDlgProc 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 Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hDc As Long, ByVal uObjectType As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function DrawFocusRect Lib "user32" (ByVal hDc As Long, lpRect As RECT) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
   
    Private hHook As Long, lPrevButtonProc As Long, hNameManager  As Long, hButton As Long, lPrevDlgProc 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 GWL_WNDPROC As Long = -4
    Const HCBT_CREATEWND = 3
    Const HC_ACTION = 0
    Const MAX_PATH = 260
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE As Long = &H10000000
    Const BS_OWNERDRAW = 11

   
    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_CREATEWND Then
        lBuff = MAX_PATH
        lret = GetClassName(wParam, sClassName, lBuff)
        If Left(sClassName, lret) = "bosa_sdm_XL9" Then
            Call UnhookWindowsHookEx(hHook)
            hNameManager = wParam
            lPrevDlgProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf DlgProc)
            hButton = CreateWindowEx(0, "Button", "Save Settings", BS_OWNERDRAW + WS_CHILD + WS_VISIBLE, _
            0, 0, 0, 0, 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 DlgProc(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
        Dim hFont As LongLong, hPrevFont As LongLong
        Dim hDlgDc As LongLong, hButtonDc As LongLong
        Dim hFilterBtn As LongLong, hEdit As LongLong
#Else
    Private Function DlgProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
            Dim hFont As Long, hPrevFont As Long
            Dim hDlgDc As Long, hButtonDc As Long
            Dim hFilterBtn As Long, hEdit As Long
#End If

    Const GWL_WNDPROC As Long = -4
    Const WM_ACTIVATE = &H6
    Const WM_SIZING = &H214
    Const WM_MOVING = &H216
    Const WM_NCCALCSIZE = &H83
    Const WM_PAINT = &HF
    Const WM_CTLCOLORBTN = &H135
    Const WM_CLOSE = &H10
    Const WM_DESTROY = &H2
    Const DT_SINGLELINE = &H20
    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const OBJ_FONT = 6
    Const TRANSPARENT = 1
    Const GW_CHILD = 5
   
    Dim tButtonRect As RECT, tFilterButnRect As RECT, tEditButnRect As RECT
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim p3 As POINTAPI, p4 As POINTAPI
   
   
    Select Case Msg
   
      Case WM_ACTIVATE, WM_SIZING, WM_MOVING, WM_NCCALCSIZE, WM_PAINT
            hFilterBtn = GetNextWindow(hwnd, GW_CHILD)
            Call GetWindowRect(hFilterBtn, tFilterButnRect)
            With tFilterButnRect
                p1.x = .Left: p1.y = .Top
                p2.x = .Right: p2.y = .Bottom
            End With
            Call ScreenToClient(hwnd, p1)
            Call ScreenToClient(hwnd, p2)
            hEdit = FindWindowEx(hwnd, 0, "EDTBX", vbNullString)
            Call GetWindowRect(hEdit, tEditButnRect)
            With tEditButnRect
                p3.x = .Left: p3.y = .Top
                p4.x = .Right: p4.y = .Bottom
            End With
            Call ScreenToClient(hwnd, p3)
            Call ScreenToClient(hwnd, p4)
            Call MoveWindow(hButton, p3.x, p4.y + 10, p2.x - p1.x + 50, p2.y - p1.y, 1)
           
        Case WM_CTLCOLORBTN
            hDlgDc = GetDC(hwnd)
            hFont = GetCurrentObject(hDlgDc, OBJ_FONT)
            Call ReleaseDC(hwnd, hDlgDc)
            hButtonDc = GetDC(hButton)
            hPrevFont = SelectObject(hButtonDc, hFont)
            Call SetBkMode(hButtonDc, TRANSPARENT)
            Call SetTextColor(hButtonDc, vbRed)
            Call GetClientRect(hButton, tButtonRect)
            Call DrawText(hButtonDc, "Save Settings", Len("Save Settings"), tButtonRect, DT_SINGLELINE + DT_CENTER + DT_VCENTER)
            Call DrawFocusRect(hButtonDc, tButtonRect)
            Call SelectObject(hButtonDc, hPrevFont)
            Call ReleaseDC(hButton, hButtonDc)
            DlgProc = CreateSolidBrush(vbYellow)
            Exit Function
           
        Case WM_CLOSE, WM_DESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevDlgProc)
           
    End Select
   
    DlgProc = CallWindowProc(lPrevDlgProc, hwnd, Msg, wParam, ByVal 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(hNameManager, GWL_WNDPROC, lPrevDlgProc)
             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


The (Restore setting code) stays the same as in Post#6
 
Last edited:
Solution

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Greg_M

New Member
Joined
Jan 28, 2017
Messages
11
Hi again Jaafar,

This just keeps getting fantastic-er and fantastic-er!!! :) :)

That "tweak" was just what I needed.

Thank you so much for what was obviously a significant amount of work on your part. I like to think that I have reasonably good Excel skills, but API programming is a completely foreign language to me.

My original thread on ExcelForum has been edited to show that you posted a solution for me on this site.

Best regards to you, and many thanks,

Greg M
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,192
Office Version
  1. 2016
Platform
  1. Windows
Greg,

I am glad it worked for you ! and thanks for the feedback and acknowledgment.

That "tweak" was just what I needed.
One final and nice tweak would be to add a second custom button in the Name Manger Dialog next to the custom "Save Settings" button for Restoring the user's saved settings ... That way, everything would be kept together and would be more intuitive and more user-friendly.

If I have time, I'll look into this and post back if anything comes up.


Thank you so much for what was obviously a significant amount of work on your part.
No worries. Actually, it was fun and gave me another excuse to play with the vba programming aspect I like the most :)
 

Greg_M

New Member
Joined
Jan 28, 2017
Messages
11
If I have time, I'll look into this and post back if anything comes up.
That would be great! I'll keep watching this thread, but don't worry if you don't have enough time - you've done more than enough for me already! :) :)

Best regards,

Greg M
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,192
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Ok- Here is the final version:

1- Save Settings button + Restore button, both added to the Name Manger Dialog accross the bottom.
2- You can save the current settings and restore them flexibly while the Name Manager dialog is still on display.
3- After closing the NM dialog, the last saved settings are stored in a newly created worksheet so they can be reloaded next time round.
4- This storage worksheet is only created once.
5- This would be ideal in an addin , so the same code works for both, xlsm and xlam (check out the second link below).

Name_Manager.xlsm
NameManagerAddin.xlam






1- Code in a Standard Module:
VBA Code:
Option Explicit

Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type Size
    cx As Long
    cy As Long
End Type

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

Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 32
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 Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetCurrentObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal uObjectType As Long) 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 SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) 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 ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function FloodFill Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

    Private hHook As LongPtr, lPrevDlgProc As LongPtr, hNameManager  As LongPtr, hSaveButton As LongPtr, hRestoreButton 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 Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function GetFocus Lib "user32" () As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    
    Private hHook As Long, lPrevDlgProc As Long, hNameManager  As Long, hSaveButton As Long, hRestoreButton As Long

#End If


Private bSettingsUpdated As Boolean
Private bUserActivation As Boolean
Private vSettingsValues(0 To 8, 2) As Variant


Public Sub Name_Manager_Hook(Control As IRibbonControl, ByRef CancelDefault)
  
  Call Hook_Name_Manager
  CancelDefault = True
  
End Sub


Public Sub Hook_Name_Manager()

    Const WH_CBT = 5

    Call GetSettingsFromSheet
    
    bUserActivation = True
    bSettingsUpdated = False
    
    Call UnhookWindowsHookEx(hHook)
    hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
    Application.Dialogs(xlDialogNameManager).Show
    Call UnhookWindowsHookEx(hHook)
    If bSettingsUpdated Then
        Call StoreSettings
        bSettingsUpdated = False
    End If    
    bUserActivation = False
    
End Sub


Private Sub StoreSettings()

    Dim oSh As Worksheet, oCurrentSheet As Worksheet
    Dim sName As String

    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
        If ThisWorkbook.IsAddin = False Then
            MsgBox "Settings Sheet Created", vbInformation
        End If
    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
    
    With ThisWorkbook
        If .IsAddin Then
            sName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
            .SaveAs Filename:=.Path & "\" & sName & ".xlam", FileFormat:=xlOpenXMLAddIn
        Else
            .Save  '<==== Save the changes to Disk to preserve the new settings.
        End If
    End With

End Sub


Private Sub RestoreSettings(Optional ByVal MsgBx As Boolean)

    Const HDM_FIRST = &H1200
    Const HDM_GETITEMCOUNT = (HDM_FIRST + 0)
    Const LVM_FIRST = &H1000
    Const LVM_SETCOLUMNWIDTH = LVM_FIRST + 30

    #If Win64 Then
        Dim hwnd As LongLong, hParent As LongLong
        Dim lCols As LongLong, lColumn As LongLong
    #Else
        Dim hwnd As Long, hParent As Long
        Dim lCols As Long, lColumn As Long
    #End If

    Dim lColWidth As Long, bMsgBox As Boolean
    
    If Len(vSettingsValues(0, 2)) = 0 Then
        Call GetSettingsFromSheet
        If Len(vSettingsValues(0, 2)) = 0 And bSettingsUpdated Then
            Call GetCurrentSettings
        Else
            If MsgBx And bMsgBox = False Then
                bMsgBox = True
                    MsgBox "Name Manager Settings have not been saved yet.", vbSystemModal + vbExclamation
                bMsgBox = False
            End If
            Exit Sub
        End If
    End If
 
    Call MoveWindow(hNameManager, vSettingsValues(0, 2), vSettingsValues(1, 2), vSettingsValues(2, 2), vSettingsValues(3, 2), 1)
    hwnd = FindWindowEx(hNameManager, 0, "XLLVP", vbNullString)
    hParent = FindWindowEx(hwnd, 0, "SysListView32", vbNullString)
    hwnd = FindWindowEx(hParent, 0, "SysHeader32", vbNullString)
    lCols = SendMessage(hwnd, HDM_GETITEMCOUNT, 0, 0)
    For lColumn = 0 To lCols - 1
        lColWidth = vSettingsValues(CLng(lColumn) + 4, 2)
        Call SendMessage(hParent, LVM_SETCOLUMNWIDTH, CLng(lColumn), ByVal lColWidth)
    Next
    
    Call UserFeddBack("Saved Settings Restored")

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 GWL_WNDPROC As Long = -4
    Const HCBT_CREATEWND = 3
    Const HCBT_ACTIVATE = 5
    Const HCBT_DESTROYWND = 4
    Const HC_ACTION = 0
    Const MAX_PATH = 260
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE As Long = &H10000000
    Const WS_BORDER = &H800000
    Const BS_OWNERDRAW = 11
    Const BS_PUSHBUTTON = &H0&
    
    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_CREATEWND Then
        lBuff = MAX_PATH
        lret = GetClassName(wParam, sClassName, lBuff)
        If Left(sClassName, lret) = "bosa_sdm_XL9" Then
            hNameManager = wParam
            lPrevDlgProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf DlgProc)
            hSaveButton = CreateWindowEx(0, "Button", "Save Settings", WS_BORDER + BS_PUSHBUTTON + BS_OWNERDRAW _
            + WS_CHILD + WS_VISIBLE, 0, 0, 0, 0, wParam, 0, GetModuleHandle(vbNullString), 0)
            hRestoreButton = CreateWindowEx(0, "Button", "Restore Settings", WS_BORDER + BS_PUSHBUTTON + BS_OWNERDRAW + _
            WS_CHILD + WS_VISIBLE, 0, 0, 0, 0, wParam, 0, GetModuleHandle(vbNullString), 0)
        End If
    End If

    If lCode = HCBT_ACTIVATE Then
        If bUserActivation Then
            bUserActivation = False
            lBuff = MAX_PATH
            lret = GetClassName(wParam, sClassName, lBuff)
            If Left(sClassName, lret) = "bosa_sdm_XL9" Then
                Call RestoreSettings
            End If
        End If
    End If
    
    Call CallNextHookEx(hHook, lCode, wParam, lParam)
    
End Function


#If Win64 Then
    Private Function DlgProc(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
        Static hSaveButtonDc As LongLong
        Static hRestoreButtonDc As LongLong
        Dim hFont As LongLong, hPrevFont As LongLong
        Dim hDlgDc As LongLong, hFocusedButtonDc As LongLong
        Dim hFilterBtn As LongLong, hEdit As LongLong
#Else
    Private Function DlgProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Static hSaveButtonDc As Long
        Static hRestoreButtonDc As Long
        Dim hFont As Long, hPrevFont As Long
        Dim hDlgDc As Long, hFocusedButtonDc As Long
        Dim hFilterBtn As Long, hEdit As Long
#End If
 
    Const GWL_WNDPROC As Long = -4
    Const WM_ACTIVATE = &H6
    Const WM_SIZING = &H214
    Const WM_MOVING = &H216
    Const WM_NCCALCSIZE = &H83
    Const WM_PAINT = &HF
    Const WM_CTLCOLORBTN = &H135
    Const WM_COMMAND = &H111
    Const WM_CLOSE = &H10
    Const DT_SINGLELINE = &H20
    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const OBJ_FONT = 6
    Const TRANSPARENT = 1
    Const GW_CHILD = 5
    
    Static tSaveButtonRect As RECT
    Static tRestoreButtonRect As RECT
    
    Dim tFilterButnRect As RECT, tEditButnRect As RECT
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim p3 As POINTAPI, p4 As POINTAPI
    
    Select Case Msg
    
        Case WM_COMMAND
            InvalidateRect FindWindowEx(hwnd, 0, vbNullString, "Restore Settings"), 0, 1
            InvalidateRect FindWindowEx(hwnd, 0, vbNullString, "Save Settings"), 0, 1
            hFocusedButtonDc = GetDC(GetFocus)
            DoEvents
            Call DrawFocusRect(hFocusedButtonDc, tSaveButtonRect)
            Call ReleaseDC(GetFocus, hFocusedButtonDc)
            If lParam = hSaveButton Then
                Call GetCurrentSettings
                bSettingsUpdated = True
                Call UserFeddBack("Current Settings Saved")
            ElseIf lParam = hRestoreButton Then
                Call RestoreSettings(True)
            End If
        
        Case WM_ACTIVATE, WM_SIZING, WM_MOVING, WM_NCCALCSIZE, WM_PAINT
            hFilterBtn = GetNextWindow(hwnd, GW_CHILD)
            Call GetWindowRect(hFilterBtn, tFilterButnRect)
            With tFilterButnRect
                p1.X = .Left: p1.Y = .Top
                p2.X = .Right: p2.Y = .Bottom
            End With
            Call ScreenToClient(hwnd, p1)
            Call ScreenToClient(hwnd, p2)
            hEdit = FindWindowEx(hwnd, 0, "EDTBX", vbNullString)
            Call GetWindowRect(hEdit, tEditButnRect)
            With tEditButnRect
                p3.X = .Left: p3.Y = .Top
                p4.X = .Right: p4.Y = .Bottom
            End With
            Call ScreenToClient(hwnd, p3)
            Call ScreenToClient(hwnd, p4)
            Call MoveWindow(hSaveButton, p3.X - 4, p4.Y + 12, p2.X - p1.X + 50, p2.Y - p1.Y, 1)
            Call MoveWindow(hRestoreButton, p3.X + (p2.X - p1.X + 65), p4.Y + 12, p2.X - p1.X + 50, p2.Y - p1.Y, 1)
        
        Case WM_CTLCOLORBTN
            hDlgDc = GetDC(hwnd)
            hFont = GetCurrentObject(hDlgDc, OBJ_FONT)
            Call ReleaseDC(hwnd, hDlgDc)
            
            If lParam = hSaveButton Then
                hSaveButtonDc = GetDC(hSaveButton)
                hPrevFont = SelectObject(hSaveButtonDc, hFont)
                Call SetBkMode(hSaveButtonDc, TRANSPARENT)
                Call SetTextColor(hSaveButtonDc, vbRed)
                Call GetClientRect(hSaveButton, tSaveButtonRect)
                Call DrawText(hSaveButtonDc, "Save Settings", Len("Save Settings"), _
                tSaveButtonRect, DT_SINGLELINE + DT_CENTER + DT_VCENTER)
                Call DrawFocusRect(hSaveButtonDc, tSaveButtonRect)
                With tSaveButtonRect 'inner focus
                    .Left = .Left + 6
                    .Top = .Top + 3
                    .Right = .Right - 6
                    .Bottom = .Bottom - 3
                End With
                Call SelectObject(hSaveButtonDc, hPrevFont)
                Call ReleaseDC(hSaveButton, hSaveButtonDc)
                DlgProc = CreateSolidBrush(vbYellow)
                Exit Function
            
            ElseIf lParam = hRestoreButton Then
                hRestoreButtonDc = GetDC(hRestoreButton)
                hPrevFont = SelectObject(hRestoreButtonDc, hFont)
                Call SetBkMode(hRestoreButtonDc, TRANSPARENT)
                Call SetTextColor(hRestoreButtonDc, vbBlue)
                Call GetClientRect(hRestoreButton, tRestoreButtonRect)
                Call DrawText(hRestoreButtonDc, "Restore Settings", Len("Restore Settings"), _
                tRestoreButtonRect, DT_SINGLELINE + DT_CENTER + DT_VCENTER)
                Call DrawFocusRect(hRestoreButtonDc, tRestoreButtonRect)
                Call SelectObject(hRestoreButtonDc, hPrevFont)
                Call ReleaseDC(hRestoreButton, hRestoreButtonDc)
                DlgProc = CreateSolidBrush(vbCyan)
                Exit Function
            
            End If
        
        Case WM_CLOSE
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevDlgProc)
    
    End Select
    
    DlgProc = CallWindowProc(lPrevDlgProc, hwnd, Msg, wParam, ByVal lParam)
 
End Function


Private Sub GetCurrentSettings()

    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 Sub GetSettingsFromSheet()

        Dim I As Long

        If SheetExists("Name_Manager_Settings") Then
         With ThisWorkbook.Sheets("Name_Manager_Settings")
            For I = 0 To 8
              vSettingsValues(I, 2) = .Cells(2, I + 1)
            Next I
        End With
        bSettingsUpdated = True
        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(ThisWorkbook.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


Private Sub UserFeddBack(ByVal Message As String)
                                                    
    Const TRANSPARENT = 1
    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const SRCCOPY = &HCC0020
    
    #If Win64 Then
        Dim hdc As LongLong, hMemDC As LongLong, hMemBmp As LongLong
        Dim hFont As LongLong, hOldFont As LongLong, hOldBmp As LongLong
    #Else
        Dim hdc As Long, hMemDC As Long, hMemBmp As Long
        Dim hFont As Long, hOldFont As Long, hOldBmp As Long
    #End If
    
    Dim tFont As LOGFONT
    Dim tTextSize As Size
    Dim tNMRect As RECT, tTextRect As RECT
    Dim X As Long, Y As Double
    Dim W As Long, H As Long
    Dim sngTimer As Single    
    
    Call GetClientRect(hNameManager, tNMRect)
    hdc = GetDC(hNameManager)
    hMemDC = CreateCompatibleDC(hdc)
    Call SetBkMode(hMemDC, TRANSPARENT)
    With tFont
        .lfHeight = 30
        .lfFaceName = "Arial" & Chr$(0)
        .lfItalic = True
    End With
    hFont = CreateFontIndirect(tFont)
    hOldFont = SelectObject(hMemDC, hFont)
    Call GetTextExtentPoint32(hMemDC, Message, Len(Message), tTextSize)
    W = tTextSize.cx
    H = tTextSize.cy
    hMemBmp = CreateCompatibleBitmap(hdc, W, H)
    hOldBmp = SelectObject(hMemDC, hMemBmp)
    X = ((tNMRect.Right - tNMRect.Left) - W) / 2
    Y = ((tNMRect.Bottom - tNMRect.Top) - H) / 3
    Call FloodFill(hMemDC, 0, 0, vbWhite)
    Call SetTextColor(hMemDC, vbRed)
    Call SetRect(tTextRect, 0, 0, W, H)
    Call DrawText(hMemDC, Message, Len(Message), tTextRect, DT_CENTER + DT_VCENTER)
    Call BitBlt(hdc, X, Y, W, H, hMemDC, 0, 0, SRCCOPY)
    sngTimer = Timer: Do: DoEvents: Loop Until Timer - sngTimer >= 1
    Call InvalidateRect(hNameManager, 0, 0)
    
    Call ReleaseDC(hNameManager, hdc)
    Call SelectObject(hMemDC, hOldFont)
    Call SelectObject(hMemDC, hOldBmp)
    Call DeleteDC(hMemDC)
    Call DeleteObject(hFont)
    Call DeleteDC(hMemBmp)

End Sub

Ribbon XML
VBA Code:
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <commands>
    <command idMso="NameManager" onAction="Name_Manager_Hook" />
  </commands>
</customUI>
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
@Jaafar Tribak, nice job!
Not sure why, but if I try to save an existing Add-In through code using SaveAs (which I have never done before, I always use Save) then a duplicate is created in the same folder. This happens regardless of which folder the Add-In is in. By the way, this duplicate has a random name without an extension. If an .XLAM extension manually is added afterwards, it turns out to be a copy of the Add-In in question, with its changed data. The loaded version of the Add-In will loose those changes when Excel is closed. I configured Excel's TrustCenter to be completely out of action. Despite this, this phenomenon continued to occur.
ScreenShot010.png



This behavior also appears to be affecting your NameManager Add-In.
Therefore I changed this part of the StoreSettings procedure ...
VBA Code:
    With ThisWorkbook
        If .IsAddin Then
            Application.DisplayAlerts = False
            sName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
            .SaveAs Filename:=.Path & "\" & sName & ".xlam", FileFormat:=xlOpenXMLAddIn
        Else
            .Save  '<==== Save the changes to Disk to preserve the new settings.
        End If
    End With

into this:
VBA Code:
    ThisWorkbook.Save

... and everything is running smoothly now. Just to let you know and many thanks.
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,192
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

@GWteB

Good catch.

Yes, you are right... the same happens here.. I should have used Save rather than SaveAs. I don't know why I missed the obvious. 😳
I have incorporated the change in the uploaded xlsm and xlam file demos.

Thanks for revising the code and for your feedback.
 

Greg_M

New Member
Joined
Jan 28, 2017
Messages
11
Hi Jaafar,

Apologies for the delay in acknowledging your last post - things have been a bit hectic at this end!

You have really gone "above and beyond the call of duty" with the help you have given me. The latest version is really all I could have ever hoped for, and then some! :):)

I can only hope that you derived as much satisfaction from developing this as I will derive from using it.

As we say in Irish: "Go raibh mile maith agat" - a thousand thanks.

Best regards,

Greg M
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,192
Office Version
  1. 2016
Platform
  1. Windows
Hi Jaafar,

Apologies for the delay in acknowledging your last post - things have been a bit hectic at this end!

You have really gone "above and beyond the call of duty" with the help you have given me. The latest version is really all I could have ever hoped for, and then some! :):)

I can only hope that you derived as much satisfaction from developing this as I will derive from using it.

As we say in Irish: "Go raibh mile maith agat" - a thousand thanks.

Best regards,

Greg M
Thanks for the feedback and glad this was useful to you... I too learnt a few things in the process.
 

Watch MrExcel Video

Forum statistics

Threads
1,128,079
Messages
5,628,539
Members
416,324
Latest member
sam_d

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top