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 nth call (here the 2nd) 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
After consulting
How to use webcam capture on a Microsoft Access form,
I have a program where the user presses a button on an Excel form to open an Access form and take before & after photos using built-in webcam then save them to a predetermined folder. This works fine on several laptops including mine but when I try to run it on a tablet with front and back camera, it prompts me to choose between UNICAM Rear and UNICAM Front, which I presume means the code works fine and is connecting to the driver. However, the chosen camera doesn't connect; WM_CAP_DRIVER_CONNECT returns False and I get a black screen in the picture frame.
The tablet is an Acer One 10 running Win10 Home 32-bit and Access 365 Runtime. The I've tested the program using Access Runtime through Command Prompt on my laptop and it worked fine, I've checked that other apps are allowed to access the camera, nothing else is using the camera, tested 0 to 9 for WM_CAP_CONNECT parameters, changed LongPtr back to Long (which by the way still makes it work on win10 Pro 64-bit) and it still doesn't work.
I suspect it's an issue with the tablet and not the code since it's a company tablet and there are two cameras, perhaps I may be missing some permissions to connect to the camera via Access or the code doesn't work with two cameras, but I have no idea where to begin checking these.
I'm currently trying to find a laptop with two cameras to test the program on and in the meantime I'm totally lost and would appreciate suggestions for anything I could try to fix this problem, whether related to the code or not - though I would like to avoid running executables like CommandCam, seeing as I'm using company computers.
This is the part of my Excel code that affects opening Access:
Private Sub mainBtn_Click()
Dim LCategoryID As Long
Dim ShellCmd, LPath As String
Dim wsMain, wsRec As Worksheet
Set wsMain = Sheets("Main")
Set wsRec = Sheets("Records")
mainBtn.Enabled = False
LPath = ThisWorkbook.Path + "\Database1.accdb"
If mainBtn.Caption <> "Record" Then
If Dir(PathToAccess) <> "" And oApp Is Nothing Then
ShellCmd = """" & PathToAccess & """ """ & LPath & """"
VBA.Shell ShellCmd
If oApp Is Nothing Then Set oApp = GetObject(LPath)
' Set oApp = CreateObject("Access.Application")
End If
Application.Wait (Now + TimeValue("00:00:05"))
On Error Resume Next
oApp.OpenCurrentDatabase LPath
oApp.Visible = False
On Error GoTo 0
'passing a value through a sub on Access
oApp.Run "getName", wsMain.Range("F5").Value
End If
'before photo
If mainBtn.Caption = "Before Photo" Then
oApp.DoCmd.openform "Before Photo"
mainBtn.Caption = "After Photo"
mainBtn.Enabled = True
This is my code in Access:
Option Compare Database
Const WS_CHILD As Long = &H40000000
Const WS_VISIBLE As Long = &H10000000
Const WM_USER As Long = &H400
Const WM_CAP_START As Long = WM_USER
Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Private Declare PtrSafe Function capCreateCaptureWindow _
Lib "avicap32.dll" Alias "capCreateCaptureWindowA" _
(ByVal lpszWindowName 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 nID As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long _
, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Sub sapiSleep Lib "kernel32" _
Alias "Sleep" _
(ByVal dwMilliseconds As Long)
Dim hCap As LongPtr
Dim i As Integer
Private Sub cmd4_click()
' take picture
Dim sFileName, sFileNameSub, dateNow, timeNow As String
i = i + 1
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(False), 0&)
dateNow = DateValue(Now)
timeNow = TimeValue(Now)
sFileName = CurrentProject.Path + "\dbimages\Before Change " + CStr(Year(dateNow)) + "." + CStr(Month(dateNow)) + "." + CStr(Day(dateNow)) + " " + CStr(Hour(timeNow)) + "h" + CStr(Minute(timeNow)) + "m" + CStr(Second(timeNow)) + "s.jpg"
Call SendMessage(hCap, WM_CAP_FILE_SAVEDIB, 0&, ByVal CStr(sFileName))
DoFinally:
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
If i = 4 Then
MsgBox "4 pictures taken. Exiting"
DoCmd.Close
Else
MsgBox "Picture " + CStr(i) + " Taken"
End If
End Sub
Private Sub Cmd3_Click()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
End Sub
Private Sub cmd1_click()
' Dim connectAttempts As Integer
Dim i As Integer
hCap = capCreateCaptureWindow("Take a Camera Shot", WS_CHILD Or WS_VISIBLE, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hWnd, 0)
If hCap <> 0 Then
'Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
' For i = 0 To 9
If CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)) = False Then
' connectAttempts = connectAttempts + 1
MsgBox "Failed to connect Camera"
Else
' Exit For
End If
' Next i
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 45, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
End If
End Sub
Private Sub Cmd2_Click()
'back to excel
'Dim temp As Long
'temp = SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
DoCmd.Close
End Sub
Private Sub Form_Close()
Dim temp As Long
temp = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, 0&, 0&)
'DoCmd.ShowToolbar "Ribbon", acToolbarYes
End Sub
Private Sub Form_Load()
'DoCmd.ShowToolbar "Ribbon", acToolbarNo
i = 0
cmd1.Caption = "Start Cam"
cmd2.Caption = "Done"
cmd3.Caption = "dummy"
cmd4.Caption = "Tak&e Picture"
DoCmd.RunCommand acCmdAppMinimize
DoCmd.Maximize
If stnName = "Head 1" Or stnName = "Head 2" Then
Pic1.Picture = CurrentProject.Path + "\images\head_s.jpeg"
ElseIf stnName = "Marriage Head" Or stnName = "Plus Clip Head" Then
Pic1.Picture = CurrentProject.Path + "\images\marriage_s.jpeg"
Else
Pic1.Picture = CurrentProject.Path + "\images\6pair_s.jpeg"
End If
cmd1_click
On Error Resume Next
CurrentProject.Application.Visible = True
End Sub
Private Sub sSleep(lngMilliSec As Long)
If lngMilliSec > 0 Then
Call sapiSleep(lngMilliSec)
End If
End Sub
EDIT: Camera app works fine on tablet but I get a black screen in picture box when trying to use it through Access.
EDIT2: Code for WM_CAP_GET_STATUS
Added the following line in main module:
Const WM_CAP_GET_STATUS = WM_CAP_START + 54
Added the following in another module:
Type CAPSTATUS
uiImageWidth As Long
uiImageHeight As Long
fLiveWindow As Long
fOverlayWindow As Long
fScale As Long
ptScroll As POINTAPI
fUsingDefaultPalette As Long
fAudioHardware As Long
fCapFileExists As Long
dwCurrentVideoFrame As Long
dwCurrentVideoFramesDropped As Long
dwCurrentWaveSamples As Long
dwCurrentTimeElapsedMS As Long
hPalCurrent As Long
fCapturingNow As Long
dwReturn As Long
wNumVideoAllocated As Long
wNumAudioAllocated As Long
End Type
New code for starting camera:
Private Sub cmd1_click()
Dim bool1, bool2, bool3 As Boolean
Dim o As Integer
Dim u As Integer
Dim s As CAPSTATUS
Open CurrentProject.Path + "\output.txt" For Output As #1
i = 0 'global variable
hCap = capCreateCaptureWindow("Take a Camera Shot", ws_child Or ws_visible, 0, 0, PicWebCam.Width, PicWebCam.Height, PicWebCam.Form.hwnd, 0)
sSleep 5000
If hCap <> 0 Then
For i = 0 To 9
Print #1, hCap
bool1 = CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, i, 0))
Print #1, bool1
bool3 = SendMessage(hCap, WM_CAP_GET_STATUS, LenB(s), s)
Print #1, bool3
For u = 1 To 4
If bool1 = True Then
bool1 = SendMessage(hCap, WM_CAP_DRIVER_DISCONNECT, i, 0&)
End If
o = u * 7
bool1 = CBool(SendMessage(hCap, WM_CAP_DRIVER_CONNECT, i, 0))
Print #1, Tab(o); bool1
bool3 = SendMessage(hCap, WM_CAP_GET_STATUS, LenB(s), s)
Print #1, Tab(o); bool3
Next u
Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 45, 0&)
Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
Next i
End If
Close #1
End Sub
I am trying to have my program check is a mapped network drive is actually connected, and change the curDrive variable based on the result. It works okay, but if the drive is still mapped and the drive is not available, there is a long delay while the program tries to connect (4-6 seconds). I tried two methods and both ways have this delay. I tried the following:
On Error GoTo switch
checker= Dir("F:\")
If checker= "" Then GoTo switch
curDrive = "F:\"
GoTo skip
switch:
curDrive = "C:\"
skip:
........
I also tried:
Dim FSO As Object '//FileSystemObject
Dim f As Object '//File Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With FSO
If .FolderExists("F:\Sample") Then
curDrive = "F:\"
Else
curDrive = "C:\"
End If
End With
Both have the same delay.
After much searching and brainstorming, I put together some info from here and from elsewhere and came up with a method that takes half a second. Basically, I'm pinging the server and reading the results from a text file. I'm also checking to make sure that the F: Drive (the server drive) is available (Someone can be on the server but hasn't set the F: Drive to the server).
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Sub CheckAllConnections()
ServerOn = ComputerIsOnline("server.mmc.local")
FDrive = CreateObject("scripting.filesystemobject").driveexists("F")
test = FDrive - 1
ProgramFolder = False
If ServerOn + FDrive = -2 Then
ProgramFolder = Len(Dir("F:\SampleProgram\")) > 0
End If
MsgBox ("Server connection is " & ServerOn & "." & Chr(10) & "F: Drive available is " & FDrive _
& Chr(10) & "The Program Folder availability is " & ProgramFolder)
End Sub
Public Function ComputerIsOnline(ByVal strComputerName As String) As Boolean
On Error Resume Next
Kill "C:\Logger.txt"
On Error GoTo ErrorHandler
ShellX = Shell("cmd.exe /c ping -n 1 " & strComputerName & " > c:\logger.txt", vbHide)
lPid = ShellX
lHnd = OpenProcess(&H100000, 0, lPid)
If lHnd <> 0 Then
lRet = WaitForSingleObject(lHnd, &HFFFF)
CloseHandle (lHnd)
End If
FileNum = FreeFile
Open "c:\logger.txt" For Input As #FileNum
strResult = Input(LOF(1), 1)
Close #FileNum
ComputerIsOnline = (InStr(strResult, "Lost = 0") > 0)
Exit Function
ErrorHandler:
ComputerIsOnline = False
Exit Function
End Function
Both show the same delay because both methods invoke the same underlying OS functionality to check for the presence of the network drive.
The OS is giving the external resource time to be available. I don't think you can do anything except await the timeout, if you want to know for sure.
If you know that, in your environment the OS timeout is just too long (e.g. "If it has not responded after 1 second, it will not respond), you could use a mechanism such as a timer to avoid waiting the full duration (set a 1 second timer when you start checking, if the timer fires and you still have no reply, the drive was not present).
There is no long delay when testing for a drive letter using the FileSystemObject and DriveExists:
Sub Tester()
Dim n As Integer
For n = 1 To 26
Debug.Print Chr(64 + n), HaveDrive(Chr(64 + n))
Next n
End Sub
Function HaveDrive(driveletter)
HaveDrive = CreateObject("scripting.filesystemobject").driveexists(driveletter)
End Function
I have the code below which works fine, steps through the rows pinging each host and updating the sheet.
Sub Do_ping()
Set output = ActiveWorkbook.Worksheets(1)
With ActiveWorkbook.Worksheets(1)
Set pinger = CreateObject("WScript.Shell")
pings = 1
pingend = "FALSE"
output.Cells(2, 4) = pings
output.Cells(2, 5) = pingend
Do
Row = 2
Do
If .Cells(Row, 1) <> "" Then
result = pinger.Run("%comspec% /c ping.exe -n 1 -w 250 " _
& output.Cells(Row, 1).Value & " | find ""TTL="" > nul 2>&1", 0, True)
If (result = 0) = True Then
result = "TRUE"
Else
result = "FALSE"
End If
' result = IsConnectible(.Cells(Row, 1), 1, 1000)
output.Cells(Row, 2) = result
End If
Row = Row + 1
Loop Until .Cells(Row, 1) = ""
waitTime = 1
Start = Timer
While Timer < Start + waitTime
DoEvents
Wend
output.Cells(2, 4) = pings
output.Cells(2, 5) = pingend
pings = pings + 1
Loop Until pingend = "TRUE"
End With
End Sub
But suppose I have 50 devices and 40 of them are down. Because it is sequential I have to wait for the pings to time out on these devices and so a single pass can take a long time.
Can I in VBA create an object that I can create multiply instances of, each pinging a separate host, and then simple cycle though the objects pulling back a true/false property from them.
I don't know how possible this is or how you deal with classes in VBA.
I want some thing like
set newhostping = newobject(pinger)
pinger.hostname = x.x.x.x
to set up the object then object would have the logic
do
ping host x.x.x.x
if success then outcome = TRUE
if not success then outcome = FALSE
wait 1 second
loop
so back in the main code I could just use
x = pinger.outcome
to give me the current state of the host, with out needing to wait for the current ping operation to complete. It would just return the result of the last completed attempt
Does any one have any code or ideas they could share?
Thank you
DevilWAH
You could use the ShellAndWait function below to run those calls asynchronously (i.e. in parallel). See my example with a simple tracert command which generally takes a few seconds to run. It opens 50 command windows running at the same time.
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Const STATUS_PENDING = &H103&
Private Const PROCESS_QUERY_INFORMATION = &H400
Public Sub test()
Dim i As Long
For i = 1 To 50
ShellandWait "tracert www.google.com", vbNormalFocus, 1
Next i
End Sub
Public Function ShellandWait(parProgramName As String, Optional parWindowStyle As VbAppWinStyle = vbMinimizedNoFocus, _
Optional parTimeOutValue As Long = 0) As Boolean
'source: http://www.freevbcode.com/ShowCode.Asp?ID=99
'Time out value in seconds
'Returns true if the program closes before timeout
Dim lInst As Long
Dim lStart As Long
Dim lTimeToQuit As Long
Dim sExeName As String
Dim lProcessId As Long
Dim lExitCode As Long
Dim bPastMidnight As Boolean
On Error GoTo ErrorHandler
lStart = CLng(Timer)
sExeName = parProgramName
'Deal with timeout being reset at Midnight
If parTimeOutValue > 0 Then
If lStart + parTimeOutValue < 86400 Then
lTimeToQuit = lStart + parTimeOutValue
Else
lTimeToQuit = (lStart - 86400) + parTimeOutValue
bPastMidnight = True
End If
End If
lInst = Shell(sExeName, parWindowStyle)
lProcessId = OpenProcess(PROCESS_QUERY_INFORMATION, False, lInst)
Do
Call GetExitCodeProcess(lProcessId, lExitCode)
DoEvents
If parTimeOutValue And Timer > lTimeToQuit Then
If bPastMidnight Then
If Timer < lStart Then Exit Do
Else
Exit Do
End If
End If
Loop While lExitCode = STATUS_PENDING
If lExitCode = STATUS_PENDING Then
ShellandWait = False
Else
ShellandWait = True
End If
Exit Function
ErrorHandler:
ShellandWait = False
End Function