Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hWnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
Private Declare PtrSafe Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByVal lpiid As Long) As Long
Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hWnd As Long, ByVal dwId As Long, ByVal riid As Long, ppvObject As Any) As Long
Private Declare Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) 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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Function ShowEditNameDialog(ByVal NameToEdit As String) As Boolean
If NameExists(NameToEdit) Then
Call SetTimer(Application.hWnd, StrPtr(NameToEdit), 0, AddressOf TimerProc)
Application.Dialogs(xlDialogNameManager).Show
ShowEditNameDialog = True
End If
End Function
' HELPER ROUTINES ...
#If Win64 Then
Private Sub TimerProc(ByVal hWnd As LongLong, ByVal uMsg As Long, ByVal nIDEvent As LongLong, ByVal dwTime As Long)
Dim hTemp As LongLong
#Else
Private Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTime As Long)
Dim hTemp As Long
#End If
Const SELFLAG_TAKESELECTION = &H2
Dim vAccChildren As Variant
Dim oAcc As IAccessible
Dim sName As String, i As Long
'Timer no longer needed so kill it now.
Call KillTimer(Application.hWnd, nIDEvent)
'Retrieve the Accessibility interface of the Names listview control.
hTemp = FindWindowEx(FindWindow("bosa_sdm_XL9", vbNullString), 0, "XLLVP", vbNullString)
hTemp = FindWindowEx(hTemp, 0, "SysListView32", vbNullString)
Set oAcc = GetAccFromHnwd(hTemp)
'Recover the Name string from its pointer.
sName = GetStringFromPointer(nIDEvent)
'Look for the Name string in the listview and select it.
Do
i = i + 1
Call AccessibleChildren(oAcc, 0&, 1&, vAccChildren, 0&)
If LCase(oAcc.accName(i)) = LCase(sName) Then
oAcc.accSelect SELFLAG_TAKESELECTION, i
Exit Do
End If
Loop Until i >= oAcc.accChildCount
'Retrieve the Accessibility interface of the main Names dialog and click the Edit button.
Set oAcc = GetAccFromHnwd(FindWindow("bosa_sdm_XL9", vbNullString))
oAcc.accDoDefaultAction (2&)
End Sub
#If Win64 Then
Private Function GetAccFromHnwd(ByVal hWnd As LongLong) As IAccessible
#Else
Private Function GetAccFromHnwd(ByVal hWnd As Long) As IAccessible
#End If
Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
Const OBJID_CLIENT = &HFFFFFFFC
Const S_OK = &H0
Dim tGUID(0 To 3) As Long
Dim oIAc As IAccessible
If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0))) = S_OK Then
If AccessibleObjectFromWindow(hWnd, OBJID_CLIENT, VarPtr(tGUID(0)), oIAc) = S_OK Then
Set GetAccFromHnwd = oIAc
End If
End If
End Function
#If Win64 Then
Private Function GetStringFromPointer(ByVal lpString As LongLong) As String
#Else
Private Function GetStringFromPointer(ByVal lpString As Long) As String
#End If
Dim lLength As Long, sBuffer As String
lLength = lstrlen(lpString)
sBuffer = Space$(lLength)
Call CopyMemory(ByVal StrPtr(sBuffer), ByVal lpString, lLength * 2)
GetStringFromPointer = sBuffer
End Function
Private Function NameExists(ByVal sName As String) As Boolean
Dim oName As Name
On Error Resume Next
Set oName = Names(sName)
On Error GoTo 0
NameExists = Not (oName Is Nothing)
End Function
