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