简体   繁体   中英

Parse Backwards in VBA for a Valid Function Name

Update

This excel-names project is contained in VBA , and it might offer some insights on the validity of various names in Excel and VBA. Unfortunately, it cannot fully guarantee validity here :

  • Names_IsValidName(sNameToTest As String) As Boolean

    Check if the name is valid:

    • true : Excel name is probably valid

    • false : Excel name is for sure not valid

Additionally, the XLParser project in C# specifies here many of the special operators and characters in Excel formulae.

However, I am still trying to determine exactly how these might apply to my solution, which must be contained in VBA.


Background

I am writing in VBA a lightweight parser for Excel formulae, which assumes that any input is syntactically valid (as validated by Excel). My goal is to properly pinpoint an entire function call within a formula.

For this, I need a function FindValidName() . This function accepts a String ending at the open parenthesis ( ( ) of a function call, and searches backward to locate the beginning of the valid formula name; or it returns -1 if no such name is found.

Question

What are the syntactic criteria for a valid function name, accessible in an Excel formula ? This does not encompass every function like VBA.Mid() accessible in VBA , since those are not accessible in Excel itself. Neither does it encompass user-defined functions (UDFs) in VBA, which are accessible in Excel and have their nomenclature defined here .

More generally, how might one algorithmize in VBA a backwards search by FindValidName() from the end of the name? Mind you, this must encompass ∪, where: is the set of names for all native functions that could ever be accessed in an Excel formula; and is the set of (syntactically valid) names for all UDFs that could ever be defined in VBA and accessed in Excel.

Note

We can assume that the formula is syntactically valid . So if we encounter (searching "backwards" from right to left) a character like + that is illegal (?) for a function name, we know that this is not simply a typo. Rather, we know that any name must start to the right of ("before") that +

= A1+SUM(B1,C1)
     |<-|

and if there are no characters "before" the + , then the ( is simply a grouping operation:

= A1+(B1*C1)
     |

What I Have

Given the below formula extracted as a String via .Formula , I can already pinpoint where a call begins.

= A1 & CONCAT(B1, C1)
             ^      ^
            14      21

I have already generalized this to FindFormulaCall(fml, [n]) , which can locate the n th call (here the 2 nd) in an arbitrarily complex formula (below).

= SUM(ABS(A1:A5)) + ABS(My_Table[@[Column Name With Punctuation: ", '@, (, ), '[, and '].]]) + ABS(B1)
                       ^                                                                   ^
                      24                                                                   92

What I Need

Now I need FindValidName("= A1 & CONCAT") to "search backwards" until the start of "CONCAT"

= A1 & CONCAT(B1, C1)
       |<----|
          6

and return the Long number of characters (measured from the end) at which that start occurs: here 6 . Alternatively, it should return -1 if no valid name is encountered.

Examples

For FindValidName("= A1 & CONCAT") the result should be 6 :

= A1 & CONCAT(B1, C1)
       |<----|
          6

For FindValidName("= A1+SUM(B1)+ABS") the result should be 3 :

= A1+SUM(B1)+ABS(C1)
             |<-|
               3

For FindValidName("= A1*SUM(B1)*") the result should be -1 for no valid name:

= A1*SUM(B1)*(C1 + D1)
             |

I don't know if the two code samples below are of any use to you. I wrote them some time ago for a teacher friend who was trying to show how Excel worked.

The first parses the formula of a cell into their individual formulas and shows how each formula resolves to the next.

The second gets a list of every formula available in a particular workbook.


Formula Parser

For the first, you'll need two helper classes, called clsParenthetical

Option Explicit

Public IsFormula As Boolean
Public FormulaName As String
Public Expression As String
Public Result As Variant
Public Index As Long

and clsParsedFormula

Option Explicit

Public KeyText As String
Public Perentheticals As Collection

Then, the main class, called clsFormulaHelper , is this:

Option Explicit

'===========================================================================
'DECLARATIONS
'===========================================================================

'---------------------------------------------------------------------------
'region PRIVATE TYPES
Private Type Points
    IsValid As Boolean
    OpenAt As Long
    CloseAt As Long
End Type
Private Type ExprKVP
    Index As Long
    Value As String
End Type
'end region PRIVATE TYPES
'---------------------------------------------------------------------------

'---------------------------------------------------------------------------
'region PRIVATE CONSTANTS
Private Const ARITHMETIC_OPR_TAG As String = "Arith"
Private Const COMPARISON_OPR_TAG As String = "Comp"
Private Const TEXT_OPR_TAG As String = "Text"
Private Const REFERENCE_OPR_TAG As String = "Ref"
'end region PRIVATE CONSTANTS
'---------------------------------------------------------------------------

'---------------------------------------------------------------------------
'region MODULE-LEVEL VARIABLES
Private mOperators As Collection
Private mRngOperators As Variant
'end region MODULE-LEVEL VARIABLES
'---------------------------------------------------------------------------

'===========================================================================
'METHODS
'===========================================================================

Public Function ParseFormula(rng As Range) As clsParsedFormula
    Const ARRAY_INC As Long = 100
    Dim pts As Points
    Dim quotes() As ExprKVP
    Dim parenthetical As clsParenthetical, p As clsParenthetical
    Dim ex As String
    Dim c As Long, i As Long
    Dim v As Variant
    
    'Validation check.
    If rng Is Nothing Then Exit Function
    If rng.Cells.Count > 1 Then Exit Function
    If Not rng.HasFormula Then Exit Function
    
    Set ParseFormula = New clsParsedFormula
    With ParseFormula
    
        .KeyText = rng.Formula
        
        'Remove any strings from the formula
        'in case target characters (eg '(' or ')')
        'are contained within the strings.
        ReDim quotes(ARRAY_INC)
        c = -1
        Do
        
            pts = FindQuotation(.KeyText)
            
            If pts.IsValid Then
            
                c = c + 1
                'Resize the array if limit is reached.
                If c > UBound(quotes) Then
                    ReDim Preserve quotes(UBound(quotes) + ARRAY_INC)
                End If
                
                'Populate the quote item with the quotation
                'and index value.
                With quotes(c)
                    .Value = Mid(ParseFormula.KeyText, _
                                 pts.OpenAt, _
                                 pts.CloseAt - pts.OpenAt + 1)
                    .Index = c
                End With
                
                'Replace the quotation with the key.
                .KeyText = Left(.KeyText, pts.OpenAt - 1) & _
                           StringKeyBuilder(c) & _
                           Right(.KeyText, Len(.KeyText) - pts.CloseAt)
            
            End If
            
            'Coninue until no further quotations found.
        Loop Until Not pts.IsValid
        
        'Reduce array to correct size.
        If c = -1 Then
            Erase quotes
        Else
            ReDim Preserve quotes(c)
        End If
        
        Set .Perentheticals = New Collection
        c = -1
        Do

            pts = FindDeepestOpenAndClose(.KeyText)

            If pts.IsValid Then
                
                c = c + 1
                ex = ExtractBackToOperator(pts.OpenAt, .KeyText)

                'Populate the parenthesis item.
                Set parenthetical = New clsParenthetical
                With parenthetical
                    .Index = c
                    .IsFormula = Len(ex) > 0
                    If .IsFormula Then
                        .FormulaName = ex
                        pts.OpenAt = pts.OpenAt - Len(ex)
                    End If
                    .Expression = Mid(ParseFormula.KeyText, _
                                      pts.OpenAt, _
                                      pts.CloseAt - pts.OpenAt + 1)


                End With
                .Perentheticals.Add parenthetical, CStr(c)

                'Replace the parenthesis with the key.
                .KeyText = Left(.KeyText, pts.OpenAt - 1) & _
                           FormulaKeyBuilder(c) & _
                           Right(.KeyText, Len(.KeyText) - pts.CloseAt)

                
            End If

        Loop Until Not pts.IsValid
        
        'Calculate the results.
        For Each parenthetical In .Perentheticals
            ex = parenthetical.Expression
            pts.OpenAt = 1
            pts.CloseAt = 0
            
            'Replace the string expressions.
            Do While True
                pts.OpenAt = InStr(pts.OpenAt, parenthetical.Expression, "{str")
                If pts.OpenAt = 0 Then Exit Do
                pts.CloseAt = InStr(pts.OpenAt, parenthetical.Expression, "}")
                If pts.CloseAt = 0 Then Exit Do
                i = ExtractIndexFromStringExpression(parenthetical.Expression, pts)
                If i >= 0 And i <= UBound(quotes) Then
                    ex = Replace(ex, "{str" & i & "}", quotes(i).Value)
                End If
                pts.OpenAt = pts.CloseAt + 1
            Loop
            
            'Replace the function expressions.
            pts.OpenAt = 1
            pts.CloseAt = 0
            Do While True
                pts.OpenAt = InStr(pts.OpenAt, parenthetical.Expression, "{f")
                If pts.OpenAt = 0 Then Exit Do
                pts.CloseAt = InStr(pts.OpenAt, parenthetical.Expression, "}")
                If pts.CloseAt = 0 Then Exit Do
                i = ExtractIndexFromFunctionExpression(parenthetical.Expression, pts)
                If i > -1 Then
                    Set p = .Perentheticals(CStr(i))
                    If Not p Is Nothing Then
                        ex = Replace(ex, "{f" & i & "}", p.Result)
                    End If
                End If
            
                pts.OpenAt = pts.CloseAt + 1
            Loop
            parenthetical.Expression = ex
            v = Evaluate(ex)
            If VarType(v) = vbString Then
                v = chr(34) & v & chr(34)
            End If
            parenthetical.Result = v
        
        Next

    End With
    
End Function

'===========================================================================
'PRIVATE HELPER FUNCTIONS
'===========================================================================

'---------------------------------------------------------------------------
'Purpose:   Converts a Long to a string key in the format {f}.
'@i:        Long to be turned into formula key.
'---------------------------------------------------------------------------
Private Function FormulaKeyBuilder(i As Long) As String
    FormulaKeyBuilder = "{f" & i & "}"
End Function

'---------------------------------------------------------------------------
'Purpose:   Converts a Long to a string key in the format {strn}.
'@i:        Long to be turned into string key.
'---------------------------------------------------------------------------
Private Function StringKeyBuilder(i As Long) As String
    StringKeyBuilder = "{str" & i & "}"
End Function

'---------------------------------------------------------------------------
'Purpose:   Finds position of open and close inverted commas.
'@txt:      string to be searched.
'Note 1:    finds closest quotation to start of string.
'Returns:   Points type. If unsuccessful IsValid = False.
'---------------------------------------------------------------------------
Private Function FindQuotation(txt As String) As Points
    Dim openPt As Long, closePt As Long, tmp As Long
    
    On Error GoTo EH
    
    openPt = InStr(txt, """")
    If openPt = 0 Then GoTo EH
    
    tmp = openPt
    Do While True
        tmp = InStr(tmp + 1, txt, """")
        If tmp = 0 Then GoTo EH
        If tmp = Len(txt) Then closePt = tmp: Exit Do
        If Mid(txt, tmp + 1, 1) <> """" Then closePt = tmp: Exit Do
        tmp = tmp + 1
    Loop
    
    With FindQuotation
        .IsValid = True
        .OpenAt = openPt
        .CloseAt = closePt
    End With
    Exit Function
    
EH:
    FindQuotation.IsValid = False
End Function

'---------------------------------------------------------------------------
'Purpose:   Finds position of open and close parenthensis at deepest level.
'@txt:      string to be searched.
'Note 1:    finds deepest Expr closest to start of string.
'Returns:   Points type. If unsuccessful IsValid = False.
'---------------------------------------------------------------------------
Private Function FindDeepestOpenAndClose(txt As String) As Points
    Dim openPt As Long, closePt As Long
    
    On Error GoTo EH
    
    closePt = InStr(txt, ")")
    If closePt = 0 Then GoTo EH
    
    openPt = InStrRev(txt, "(", closePt)
    If openPt = 0 Then GoTo EH
    
    With FindDeepestOpenAndClose
        .IsValid = True
        .OpenAt = openPt
        .CloseAt = closePt
    End With
    
    Exit Function
    
EH:
    FindDeepestOpenAndClose.IsValid = False
End Function

'---------------------------------------------------------------------------
'Purpose:   Determines if char is any Excel operator.
'@char:     Character to be evaluated.
'Returns:   True if successful.
'---------------------------------------------------------------------------
Private Function IsOperator(char As String, _
                            Optional arithOpr As Boolean = True, _
                            Optional compOpr As Boolean = True, _
                            Optional textOpr As Boolean = True, _
                            Optional refOpr As Boolean = True) As Boolean
    
    Dim exists As Boolean
    Dim opr As Collection
    
    On Error Resume Next
    If arithOpr Then
        Set opr = mOperators(ARITHMETIC_OPR_TAG)
        If Not opr Is Nothing Then
            exists = opr(char)
            If exists Then
                IsOperator = True
                Exit Function
            End If
        End If
    End If
    
    If compOpr Then
        Set opr = mOperators(COMPARISON_OPR_TAG)
        If Not opr Is Nothing Then
            exists = opr(char)
            If exists Then
                IsOperator = True
                Exit Function
            End If
        End If
    End If
    
    If textOpr Then
        Set opr = mOperators(TEXT_OPR_TAG)
        If Not opr Is Nothing Then
            exists = opr(char)
            If exists Then
                IsOperator = True
                Exit Function
            End If
        End If
    End If
     
    If refOpr Then
        Set opr = mOperators(REFERENCE_OPR_TAG)
        If Not opr Is Nothing Then
            exists = opr(char)
            If exists Then
                IsOperator = True
                Exit Function
            End If
        End If
    End If
 
End Function

'---------------------------------------------------------------------------
'Purpose:   Extracts string from a nominated position backwards as far as
'           any operator or start of string.
'@pt:       position in string to commence extraction.
'@str:      string for extraction.
'Note 1:    Target string length must be greater than 1.
'Returns:   Extracted text or null string if no operator is found.
'---------------------------------------------------------------------------
Private Function ExtractBackToOperator(pt As Long, str As String) As String
    Dim i As Long
    Dim chr As String
    
    If pt < 2 Then Exit Function
    
    For i = pt - 1 To 1 Step -1
        chr = Mid(str, i, 1)
        If IsOperator(chr) Then
            ExtractBackToOperator = Mid(str, i + 1, pt - (i + 1))
            Exit Function
        End If
    Next
End Function

'---------------------------------------------------------------------------
'Purpose:   Extracts index number from function expression.
'@expr:     Target expression.
'@pts:      start and end point of function.
'Returns:   Index number or -1 of failed.
'---------------------------------------------------------------------------
Private Function ExtractIndexFromFunctionExpression(expr As String, pts As Points) As Long
    On Error GoTo EH
    ExtractIndexFromFunctionExpression = Mid(expr, pts.OpenAt + 2, pts.CloseAt - pts.OpenAt - 2)
    Exit Function
EH:
    ExtractIndexFromFunctionExpression = -1
End Function
'---------------------------------------------------------------------------
'Purpose:   Extracts index number from string expression.
'@expr:     Target expression.
'@pts:      start and end point of function.
'Returns:   Index number or -1 of failed.
'---------------------------------------------------------------------------
Private Function ExtractIndexFromStringExpression(expr As String, pts As Points) As Long
    On Error GoTo EH
    ExtractIndexFromStringExpression = Mid(expr, pts.OpenAt + 4, pts.CloseAt - pts.OpenAt - 4)
    Exit Function
EH:
    ExtractIndexFromStringExpression = -1
End Function

Private Sub Class_Initialize()
    Dim opr As Collection
    
    Set mOperators = New Collection
    Set opr = New Collection
    opr.Add True, "+"
    opr.Add True, "-"
    opr.Add True, "*"
    opr.Add True, "/"
    opr.Add True, "%"
    opr.Add True, "^"
    mOperators.Add opr, ARITHMETIC_OPR_TAG
    
    Set opr = New Collection
    opr.Add True, "="
    opr.Add True, ">"
    opr.Add True, "<"
    mOperators.Add opr, COMPARISON_OPR_TAG
    
    Set opr = New Collection
    opr.Add True, "&"
    mOperators.Add opr, TEXT_OPR_TAG
    
    Set opr = New Collection
    opr.Add True, ":"
    opr.Add True, ","
    opr.Add True, " "
    mOperators.Add opr, REFERENCE_OPR_TAG
    
End Sub

You would call it in a module like this:

Dim helper As clsFormulaHelper
Dim parsedFormula As clsParsedFormula
Dim parenthetical As clsParenthetical

Set helper = New clsFormulaHelper
Set parsedFormula = helper.ParseFormula(Sheet1.Range("A4"))

Here are the outputs:

For formula: =IF(A1*(A1 + 'AB + CD',A2) = 3, SUM(A1,A2,'AB + CD',A3): IF(A1 = 2, AVERAGE(A1:A3),"c" & COUNT(A1:A3)))

Nested index: 0, Expr: (A1 + 'AB + CD',A2): Result: 3

Nested index: 1, Expr: SUM(A1,A2,'AB + CD',A3): Formula, SUM: Result: 6

Nested index: 2, Expr: AVERAGE(A1:A3), Formula: AVERAGE, Result: 2

Nested index: 3, Expr: COUNT(A1:A3), Formula: COUNT, Result: 3

Nested index: 4, Expr: IF(A1 = 2, 2,"c" & 3), Formula: IF, Result: "c3"

Nested index: 5, Expr: IF(A1*3 = 3, 6, "c3"), Formula: IF, Result: 6


Available Formulas

The second code sample gets a list of all formulas available in the workbook. It will only work on 64-bit.

Option Explicit

'---------------------------------------------------------
'Hook APIs and Constants
'---------------------------------------------------------
Private Declare PtrSafe Function SetWinEventHook _
    Lib "user32" _
    (ByVal eventMin As Long, _
    ByVal eventMax As Long, _
    ByVal hmodWinEventProc As LongPtr, _
    ByVal pfnWinEventProc As LongPtr, _
    ByVal idProcess As Long, _
    ByVal idThread As Long, _
    ByVal dwFlags As Long) As LongPtr
    
Private Declare PtrSafe Function UnhookWinEvent _
    Lib "user32" _
    (ByVal hWinEventHook As LongPtr) As Long
    
Private Declare PtrSafe Function GetCurrentProcessId _
    Lib "kernel32" () As Long

Private Declare PtrSafe Function GetWindowThreadProcessId _
    Lib "user32" _
    (ByVal hWnd As LongPtr, _
    lpdwProcessId As Long) As Long

Private Declare PtrSafe Function GetClassName _
    Lib "user32" Alias "GetClassNameA" _
    (ByVal hWnd As LongPtr, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long
    
Private Const EVENT_OBJECT_CREATE As Long = 32768
Private Const WINEVENT_OUTOFCONTEXT As Long = 0
    
'---------------------------------------------------------
'Subclassing APIs and Constants
'---------------------------------------------------------
Private Declare PtrSafe Function SetWindowLongPtr _
    Lib "user32" Alias "SetWindowLongPtrA" _
    (ByVal hWnd As LongPtr, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As LongPtr) As LongPtr

Private Declare PtrSafe Function CallWindowProc _
    Lib "user32" Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As LongPtr, _
    ByVal hWnd As LongPtr, _
    ByVal iMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr) As LongPtr
    
Private Declare PtrSafe Sub CopyMemory _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, _
    Source As Any, _
    ByVal Length As Long)
    
Private Declare PtrSafe Function lstrlenW _
    Lib "kernel32" _
    (ByVal lpString As LongPtr) As Long

Private Const GWLP_WNDPROC As Long = (-4)
Private Const WM_NOTIFY As Long = &H4E

Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETTOPINDEX  As Long = (LVM_FIRST + 39)
Private Const LVM_GETSTRINGWIDTHW = (LVM_FIRST + 87)
    
'---------------------------------------------------------
'Timer APIs
'---------------------------------------------------------
Private Declare PtrSafe Function SetTimer _
    Lib "user32" _
    (ByVal hWnd As LongPtr, _
    ByVal nIDEvent As Long, _
    ByVal uElapse As Long, _
    ByVal lpTimerFunc As LongPtr) As Long

Public Declare PtrSafe Function KillTimer Lib _
    "user32" _
    (ByVal hWnd As Long, _
    ByVal nIDEvent As Long) As Long

Private Const LISTVIEW_NAME As String = "SysListView32"
Private Const REDUNDANT_LV_STRING As String = "W"

Private mHHook As LongPtr
Private mHListView As LongPtr
Private mPrevWndProc As LongPtr
Private mTimerId As Long
Private mFormulas As Collection
Private mHasFormulas As Boolean
Private mOldA1Value As Variant

Public Property Get GrabbedFormulas() As Collection
    Set GrabbedFormulas = mFormulas
End Property

Public Property Get HasGrabbedFormulas() As Boolean
    HasGrabbedFormulas = mHasFormulas
End Property
Public Sub GrabEm()

    '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    'ONLY CALL THIS ROUTINE FROM THE WORKSHEET ITSELF.
    'EITHER A SHEET BUTTON OR WORKSHEET EVENT WOULD BE OKAY.
    'RUNNING FROM VBA EDITOR WILL DO SERIOUS DAMAGE TO YOUR WORK.
    '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
    Dim ws As Worksheet
    
    On Error GoTo EH
    
    'Warning
    MsgBox _
        "Please do not touch the keyboard or activate another window." & vbNewLine & vbNewLine & _
        "We are about to grab all of the workbook formulas by simulating key strokes on this sheet. " & vbNewLine & vbNewLine & _
        "This routine will take a few seconds.", _
        vbOKOnly, _
        "Formula Grabber"
    
    'Initialise.
    Set mFormulas = New Collection
    mHasFormulas = False
    
    Set ws = ThisWorkbook.Worksheets(1)
    With ws
        .Visible = xlSheetVisible
        .Activate
        With .Range("A1")
            mOldA1Value = .Value
            .Select
        End With
    End With
    
    'First task is to find the SysListView32 handle.
    'We'll hook a EVENT_OBJECT_CREATE win event, which
    'we can 'coerce' by entering "=a" in a cell.
    If mHHook <> 0 Then DetachHook
    mHHook = SetWinEventHook(EVENT_OBJECT_CREATE, _
                             EVENT_OBJECT_CREATE, _
                             0, _
                             AddressOf WinEventProc, _
                             0, _
                             0, _
                             WINEVENT_OUTOFCONTEXT)
    
    RunKeySequence Asc("a")
    
    Do While Not mHasFormulas
        DoEvents
    Loop

EH:
    ws.Range("A1").Value = mOldA1Value
    ReleaseAll
End Sub

Private Function WinEventProc(ByVal hWinEventHook As LongPtr, _
                             WinEvent As Long, _
                             ByVal hWnd As LongPtr, _
                             ByVal idObject As Long, _
                             ByVal idChild As Long, _
                             ByVal idEventThread As Long, _
                             ByVal dwmsEventTime As Long) As Long

    On Error GoTo EH
    
    'We don't want to handle or subclass a window created by a different process.
    If Not IsSameProcess(hWnd) Then Exit Function
    
    'Disregard any class that isn't a SysListView32.
    If Not IsListView(hWnd) Then Exit Function
    
    'We have the handle, so now we can release the hook
    'and create a subclass.
    'Note: store the handle for emergency hook destruction.
    mHListView = hWnd
    DetachHook
    mPrevWndProc = SetWindowLongPtr(mHListView, _
                                    GWLP_WNDPROC, _
                                    AddressOf SubbedWndProc)
    Exit Function
EH:
End Function

Private Function SubbedWndProc(ByVal hWnd As LongPtr, _
                               ByVal iMsg As Long, _
                               ByVal wParam As LongPtr, _
                               ByVal lParam As LongPtr) As LongPtr
    
    Dim str As String
    On Error Resume Next
    
    'The two messages we're interested in are:
    '1. LVM_GETSTRINGWIDTHW which is sent
    '   for each item to size the window.
    '2. LVM_GETTOPINDEX which is sent once
    '   all strings are measured.
    Select Case iMsg
        Case LVM_GETSTRINGWIDTHW
            'A pointer to the string is passed in lParam.
            str = PointerToString(lParam)
            If str <> REDUNDANT_LV_STRING Then
                mFormulas.Add str, str
            End If
        Case LVM_GETTOPINDEX
            'We're ready to move on to next keystroke.
            RunKeySequence
    End Select
    
    'We're not overriding anything, so pass all messages
    'to previous window procedure.
    SubbedWndProc = CallWindowProc(mPrevWndProc, _
                                   hWnd, _
                                   iMsg, _
                                   wParam, _
                                   lParam)
End Function

Private Sub RunKeySequence(Optional startKey As Long)
    Static key As Long
    
    On Error GoTo EH
    
    'Pause the timer.
    StopTimer
    
    'Start the sequence.
    If startKey <> 0 Then
        key = startKey
        Application.SendKeys "="
        Application.SendKeys chr(key)
    Else
        key = key + 1
    End If
    
    'End the sequence.
    If key < Asc("a") Or key > Asc("z") Then
        'Destroy the subclass.
        Unsubclass
        'Clear the cell.
        Application.SendKeys "{BACKSPACE}"
        Application.SendKeys "{BACKSPACE}"
        Application.SendKeys "{ENTER}"
        
        mHasFormulas = True
        Exit Sub
    End If
    
    'Send the next keys.
    StartTimer
    Application.SendKeys "{BACKSPACE}"
    'Note: API timer is used in case no formulas begin with
    'the entered letter (ie no message would then be
    'sent to our wnd proc) so we can time out that letter.
    Application.SendKeys chr(key)
    Exit Sub
EH:
End Sub

Private Sub StartTimer()
    On Error Resume Next
    mTimerId = SetTimer(0, 0, 1000, AddressOf TimerProc)
End Sub

Private Sub StopTimer()
    On Error Resume Next
    KillTimer 0, mTimerId
End Sub
Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    RunKeySequence
End Sub

Private Sub DetachHook()
    On Error Resume Next
    UnhookWinEvent mHHook
    mHHook = 0
End Sub

Private Sub Unsubclass()
    On Error Resume Next
    SetWindowLongPtr mHListView, GWLP_WNDPROC, mPrevWndProc
    mPrevWndProc = 0
End Sub

Private Function IsSameProcess(hWnd) As Boolean
    Dim windowId As Long, currentId As Long
    
    On Error GoTo EH
    GetWindowThreadProcessId hWnd, windowId
    currentId = GetCurrentProcessId
    IsSameProcess = (windowId = currentId)
    Exit Function
EH:
End Function

Private Function IsListView(hWnd) As Boolean
    Dim ret As Long
    Dim str As String * 128
    Dim clsName As String
    
    On Error GoTo EH
    ret = GetClassName(hWnd, str, Len(str))
    clsName = Left(str, ret)
    
    IsListView = (clsName = LISTVIEW_NAME)
    Exit Function
EH:
End Function

Private Function PointerToString(psz As LongPtr) As String
    Dim buffer As Long
    Dim str As String
    
    On Error GoTo EH
    buffer = lstrlenW(psz) * 2
    str = Space(buffer)
    CopyMemory ByVal str, ByVal psz, buffer
    PointerToString = Replace(str, chr(0), "")
    Exit Function
EH:
End Function
Public Sub ReleaseAll()
    StopTimer
    Unsubclass
    DetachHook
End Sub



Function nested index = 2 Expression = AVERAGE(A1:A3) Formula = AVERAGE Evaluated result = 2

Function nested index = 3 Expression = COUNT(A1:A3) Formula = COUNT Evaluated result = 3

Function nested index = 4 Expression = IF(A1 = 2, 2,"c" & 3) Formula = IF Evaluated result = "c3"

Function nested index = 5 Expression = IF(A1*3 = 3, 6, "c3") Formula = IF Evaluated result = 6

I have developed a compact suggestion in VBA , which is here awaiting review on Code Review . It should be easily repurposed into a direct solution for this question.

This suggestion is a single function NameIsValid(name) , which evaluates a string and determines if it is a valid name in Excel. With appropriate safeguards in place, it does so by splicing the name into a call to LET() , which it then executes using Application.Evaluate() . An invalid name will yield an Error .

' Check if a name is valid: it may be "declared" in Excel using LET().
Public Function NameIsValid(name As String) As Boolean
    ' Invalidate names that are empty or too long.
    If name = Empty Or VBA.Len(name) > 255 Then
        NameIsValid = False
    ' Invalidate reserved names: "R" and "C".
    ElseIf ( _
        name = "C" Or name = "c" Or _
        name = "R" Or name = "r" _
    ) Then
        NameIsValid = False
    ' Invalidate names with external whitespace (or double spaces internally),
    ' which are invalid in names and yet could mesh syntactically with
    ' formulaic calls to LET() in Excel.
    ElseIf name <> Application.WorksheetFunction.Clean(VBA.Trim(name)) Then
        NameIsValid = False
    ' Invalidate names with injection characters, which are invalid in names
    ' and also disrupt formulaic calls to LET() in Excel.
    ElseIf ( _
        VBA.InStr(1, name, "(") Or _
        VBA.InStr(1, name, ",") Or _
        VBA.InStr(1, name, ";") Or _
        VBA.InStr(1, name, ")") _
    ) Then
        NameIsValid = False
    ' If we pass the above checks, we can safely splice the name into a
    ' formulaic declaration with LET() in Excel.
    Else
        ' Get the result of formulaically declaring a name with LET() in Excel.
        Dim eval As Variant
        eval = Application.Evaluate("= LET(" & name & ", 0, 0)")
        
        ' Check if the declaration erred due to invalid nomenclature.
        If IsError(eval) Then
            NameIsValid = False
        Else
            NameIsValid = True
        End If
    End If
End Function

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM