Option Explicit
#If VBA7 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As Long
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
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
#Else
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Function GetForegroundWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
#End If
Sub Test()
Dim sSheetName As String
Application.DisplayAlerts = False
EnableSheetSelection = True
sSheetName = Application.InputBox("Where is the source data?")
EnableSheetSelection = False
If Len(sSheetName) And sSheetName <> "False" Then
If SheetExists(sSheetName) Then
Sheets(sSheetName).Select
Else
Debug.Print "Invalid Sheet."
End If
End If
End Sub
Private Sub AdjustSheetName()
Const EM_SETSEL = &HB1
#If VBA7 Then
Dim hwnd As LongPtr
#Else
Dim hwnd As Long
#End If
Dim sBuff As String * 256, lRet As Long
Dim sSheetName As String
On Error GoTo ErrHandler
hwnd = GetDlgItem(GetForegroundWindow, &H13)
lRet = GetWindowText(hwnd, sBuff, 256)
sSheetName = Left(sBuff, lRet)
If Len(sSheetName) And SheetExists(sSheetName) = False Then
sSheetName = Mid(sSheetName, InStr(1, sSheetName, "+", vbTextCompare) + 1, Len(sSheetName))
sSheetName = Replace(Replace(Replace(sSheetName, "=", ""), "!", ""), "'", "")
SetWindowText hwnd, sSheetName
Call SendMessage(hwnd, EM_SETSEL, ByVal CLng(Len(sSheetName)), ByVal CLng(Len(sSheetName)))
End If
Exit Sub
ErrHandler:
KillTimer Application.hwnd, 0
End Sub
Private Function SheetExists(ByVal SheetName As String) As Boolean
Dim sh As Worksheet
On Error Resume Next
Set sh = Sheets(SheetName)
SheetExists = Not (sh Is Nothing)
End Function
Private Property Let EnableSheetSelection(ByVal Enable As Boolean)
If Enable Then
SetTimer Application.hwnd, 0, 0, AddressOf AdjustSheetName
Else
KillTimer Application.hwnd, 0
End If
End Property