VBA - Find all numbered lines in VBE Modules via pattern search - vba

Task:
My goal is to find all numbered lines in procedures of my Code Modules.
The CodeModule.Find method can be used to check for search terms (target parameter).
Syntax:
object.Find(target, startline, startcol, endline, endcol [, wholeword] [, matchcase] [, patternsearch])
The referring help site https://msdn.microsoft.com/en-us/library/aa443952(v=vs.60).aspx states:
parameter patternsearch: Optional. A Boolean value specifying whether or not the target string is a regular expression pattern.
If True, the target string is a regular expression pattern. False is the default.
As explained above the find method allows a regex pattern search, which I would like to use in order to identify numbered lines in a precise way:
digits followed by a tab. The example below therefore defines a search string s and sets the last parameter PatternSearch in the .Find method to True.
Problem
AFAIK a valid regex definition could be
s = "[0-9]{1,4}[ \t]"
but that doesn't show anything, not even an error.
In order to show at least any results, I defined the search term
s = "[0-9]*[ \t]*)"
in the calling example procedure ListNumberedLines showing erratic results.
Question
Is there any possibility to use a valid regex patternsearch in the CodeModule.Find method?
Example code
Option Explicit
' ==============
' Example Search
' ==============
Sub ListNumberedLines()
' Declare search pattern string s
Dim S As String
10 S = "[0-9]*[ \t]*)"
20 Debug.Print "Search Term: " & S
30 Call findWordInModules(S)
End Sub
Public Sub findWordInModules(ByVal sSearchTerm As String)
' Purpose: find modules ('components') with lines containing a search term
' Method: .CodeModule.Find with last parameter patternsearch set to True
' Based on https://www.devhut.net/2016/02/24/vba-find-term-in-vba-modulescode/
' VBComponent requires reference to Microsoft Visual Basic for Applications Extensibility
' or keep it as is and use Late Binding instead
' Declare module variable oComponent
Dim oComponent As Object 'VBComponent
For Each oComponent In Application.VBE.ActiveVBProject.VBComponents
If oComponent.CodeModule.Find(sSearchTerm, 1, 1, -1, -1, False, False, True) = True Then
Debug.Print "Module: " & oComponent.Name 'Name of the current module in which the term was found (at least once)
'Need to execute a recursive listing of where it is found in the module since it could be found more than once
Call listLinesinModuleWhereFound(oComponent, sSearchTerm)
End If
Next oComponent
End Sub
Sub listLinesinModuleWhereFound(ByVal oComponent As Object, ByVal sSearchTerm As String)
' Purpose: list module lines containing a search term
' Method: .CodeModule.Find with last parameter patternsearch set to True
Dim lTotalNoLines As Long 'total number of lines within the module being examined
Dim lLineNo As Long 'will return the line no where the term is found
lLineNo = 1
With oComponent ' Module
lTotalNoLines = .CodeModule.CountOfLines
Do While .CodeModule.Find(sSearchTerm, lLineNo, 1, -1, -1, False, False, True) = True
Debug.Print vbTab & "Zl. " & lLineNo & "|" & _
Trim(.CodeModule.Lines(lLineNo, 1)) 'Remove any padding spaces
lLineNo = lLineNo + 1 'Restart the search at the next line looking for the next occurence
Loop
End With
End Sub

As #MatsMug says, parsing VBA with Regex is hard impossible, but line-numbers are a simpler case, and should be findable with regex alone.
Fortunately, line numbers can only appear within a procedure body (including before the End Sub/Function/Property statement), so we know they'll never be the first line of your code.
Unfortunately, you can prefix a line-label with 0 or more line continuations:
Sub Foo()
_
_
10 Beep
End Sub
Furthermore, a line number isn't always followed by a space - it can be followed by an instruction separator, giving the line-number the appearance of a line-label:
Sub foo()
10: Beep
End Sub
And if you're code is evil, you might encounter a negative line-number (entered by using hex notation - which VBE dutifully pretty prints back to the code-pane with a leading space and a negative number):
Sub foo()
10 Beep
-1 Beep
End Sub
And we also need to be able to identify numbers that appear on a continued line, that aren't line-numbers:
Sub foo()
Debug.Print _
5 & "is not a line-number"
End Sub
So, here's some evil line-numbering, with a mix of all of those edge-cases:
Option Explicit
Sub foo()
5: Beep
_
_
_
10 Beep
20 _
'Debug.Print _
30
50: Beep
40 Beep
_
-1 _
Beep 'The "-1" line number is achieved by entering "&HFFFFFFFF"
Debug.Print _
2 & "is not a line-number"
60 End Sub
And here's some regex that identifies the line-numbers:
(?<! _)\n( _\n)* ?(?<line_number>(?:\-)?\d+)[: ]
And here's a syntax highlight from regex101:

For the longest time, Rubberduck was struggling with properly/formally parsing line numbers - our work-around was to remove them (replacing them with spaces) before feeding the code module contents to our parser.
Recently we've managed to formally define line numbers:
// lineNumberLabel should actually be "statement-label" according to MS VBAL but they only allow lineNumberLabels:
// A <statement-label> that occurs as the first element of a <list-or-label> element has the effect
// as if the <statement-label> was replaced with a <goto-statement> containing the same
// <statement-label>. This <goto-statement> takes the place of <line-number-label> in
// <statement-list>.
listOrLabel :
lineNumberLabel (whiteSpace? COLON whiteSpace? sameLineStatement?)*
| (COLON whiteSpace?)? sameLineStatement (whiteSpace? COLON whiteSpace? sameLineStatement?)*
;
sameLineStatement : blockStmt;
And lineNumberLabel is defined as:
//Statement labels can only appear at the start of a line.
statementLabelDefinition : {_input.La(-1) == NEWLINE}? (combinedLabels | identifierStatementLabel | standaloneLineNumberLabel);
identifierStatementLabel : unrestrictedIdentifier whiteSpace? COLON;
standaloneLineNumberLabel :
lineNumberLabel whiteSpace? COLON
| lineNumberLabel;
combinedLabels : lineNumberLabel whiteSpace identifierStatementLabel;
lineNumberLabel : numberLiteral;
(full Antlr4 grammar here)
Notice the predicate {_input.La(-1) == NEWLINE}?, which force the parser rule to only match a statementLabelDefinition at the start of a line - a logical line of code.
You see VBA code has physical code lines, like what you're getting from the CodeModule's contents. But VBA code also has a concept of logical code lines, and it turns out that is all the parser cares about.
This would trip any typical regex:
Sub DoSomething()
Debug.Print _
42
End Sub
There's only 1 logical line of code between the signature and the End Sub token, but a simple Find will happily consider that 42 as a "line number" ...which it isn't - it's the argument passed to Debug.Print, in the same instruction, on the same logical code line, but on the next physical code line.
And you can't be dealing with logical code lines without first pre-processing your input, to take line continuation tokens into account.
And in order to do that, you need to actually parse the instructions you're seeing - at least know where they start and where they end... and that's no small undertaking! see ThunderFrame's answer
The VBIDE API is extremely limited, and won't be helpful for that.
TL;DR: You can't parse VBA code with regular expressions alone. So, nope. Sorry! you need a much more complex regex pattern than that - see ThunderFrame's answer.

Conclusion regarding CodeModule.Find via search pattern
Firstly, CodeModule.Find doesn't help via search pattern and its possible use is intransparent.
I agree that the VBIDE API is extremely limited and that there exist excellent professional tools which I highly recommand for any programmer :-)
Consequence: Work around via XML
Secondly I prefer household remedies if possible, so I tried to find an alternative solution using only the helpful parts of VBIDE.
Method
That is why I tried a simple xml conversation of the CodeModule.Lines allowing a flexible search within logical lines.
Instead of using regular expressions in requesting the xml data, I demonstrate a method to find leading numbers via a well defined XPath search (loop thru node list),
thus resolving most problems shown by #ThunderFrame. The search string in function showErls is defined as "line[substring(translate(.,'0123456789','¹¹¹¹¹¹¹¹¹¹'),1,1)="¹"]"
Furthermore function 'lineNumber' returns the logical line number within the module.
Note: To keep it simple, the search is restrained to one module only (user defined constant MYMODULE) and code avoids any regex.
Work around code - main sub
Option Explicit
' ==========================================
' User defined name of module to be analyzed
' ==========================================
Const MYMODULE = "modThunderFrame" ' << change to existing module name or userform
' Declare xml file as object
Dim xCMods As Object ' Late Binding; instead of Early Bd: Dim xCMods As MSXML2.DOMDocument6
Public Sub TestLineNumbers()
' =================
' A. Load/refresh code into xml
' =================
' set xml into memory - contains code module(s) lines
Set xCMods = CreateObject("MSXML2.Domdocument.6.0") ' L.Bd.; instead of E.Bd: Set xCMods = New MSXML2.DOMDocument60
xCMods.async = False
xCMods.validateOnParse = False
' read in user defined code module and load xml, if failed show error message
refreshCM MYMODULE
If xCMods Is Nothing Then Exit Sub
' ======================
' B. search line numbers
' ======================
showERLs
' =============================
' C. Save xml if needed
' =============================
' xCMods.Save ThisWorkbook.Path & "\VBE(" & MYMODULE & ").xml"
' MsgBox "Successfully exported Excel data to " & ThisWorkbook.Path & "\VBE(" & MYMODULE & ").XML!", _
' vbInformation, "Module " & MYMODULE & " to xml"
' =================
' D. terminate xml
' =================
Set xCMods = Nothing
End Sub
Sub procedures
Private Sub showERLs()
' Purpose: [B.] declare XPath search string and define special translate character
Dim s As String
Dim S1 As String: S1 = Chr(185) ' superior number 1 (hex B9) replaces any digit
' declare node and node list
Dim line As Object
Dim lines As Object
' define XPath search string for first digit in line (usual case)
s = "line[substring(translate(.,'0123456789','" & String(10, S1) & "'),1,1)=""" & _
S1 & _
"""]"
' start debugging
Debug.Print "**search string=""" & s & """" & vbNewLine & String(50, "-")
Debug.Print "Line #|Line Content" & vbNewLine & String(50, "-"); ""
' set node list
Set lines = xCMods.DocumentElement.SelectNodes(s)
' -------------------
' loop thru node list
' -------------------
For Each line In lines
Debug.Print Format(lineNumber(line), "00000") & "|" & line.Text ' return logical line number plus line content
Next line
End Sub
Private Sub refreshCM(sModName As String)
' Purpose: [A.] load xml string via LoadXML method
Dim sErrTxt As String
Dim line As Object
Dim lines As Object
Dim xpe As Object
Dim s As String ' xpath expression
Dim pos As Integer ' position of line number prefix
' ======================================
' 1. Read code module lines and load xml
' ======================================
If Not xCMods.LoadXML(readCM(sModName)) Then
' set ParseError object
Set xpe = xCMods.parseError
With xpe
sErrTxt = sErrTxt & vbNewLine & String(20, "-") & vbNewLine & _
"Loading Error No " & .ErrorCode & " of xml file " & vbCrLf & _
Replace(" " & Replace(.URL, "file:///", "") & " ", " ", "[No file found]") & vbCrLf & vbCrLf & _
xpe.reason & vbCrLf & _
"Source Text: " & .srcText & vbCrLf & _
"char?: " & """" & Mid(.srcText, .linepos, 1) & """" & vbCrLf & vbCrLf & _
"Line no: " & .line & vbCrLf & _
"Line pos: " & .linepos & vbCrLf & _
"File pos.: " & .filepos & vbCrLf & vbCrLf
End With
MsgBox sErrTxt, vbExclamation, "XML Loading Error"
Set xCMods = Nothing
Exit Sub
End If
' 2. resolve hex input problem of negative line numbers with leading space (thx #Thunderframe)
s = "line"
Set lines = xCMods.DocumentElement.SelectNodes(s)
' loop thru all logical lines
For Each line In lines
pos = ErlPosInLine(line.Text)
If pos <= Len(line.Text) Then
' to do: add attribute to line node, if wanted
' correct line content
line.Text = Mid(line.Text, pos)
End If
Next
End Sub
Private Function lineNumber(node As Object) As Long
' Purpose: [B.] return logical line number within code module lines
' Param.: IXMLDomNode
' Method: XPath via preceding-sibling count plus one
Dim tag As String: tag = "line"
lineNumber = node.SelectNodes("preceding-sibling::" & tag).Length + 1
End Function
Private Function readCM(Optional modName = "*") As String
' Purpose: return code module line string (VBIDE) of a user defined module to be read into xml
' Call: called from [A.] refreshCM
' xCMods.LoadXML(readCM(sModName))
' Declare variable
Dim s As String
Dim md As CodeModule
If modName = "*" Then Exit Function
On Error GoTo OOPS
' get code module lines into string
Set md = Application.VBE.ActiveVBProject.VBComponents(modName).CodeModule ' MSAccess: Modules("modVBELines")
' change to xml tags
s = getTags(md.lines(1, md.CountOfLines))
' return
readCM = s
OOPS:
End Function
Private Function getTags(ByVal s As String, Optional mode = False) As String
' Purpose: prepares xml string to be loaded
' define constant
Const HEAD = "<?xml version=""1.0"" encoding=""utf-8""?>" & vbCrLf & "<cm>" & vbCrLf
' 1. change tag characters
s = Replace(Replace(s, "<", "<"), ">", ">")
' 2. change special characters (ampersand)
s = Replace(s, "&", "&")
' 3. change "_" points
s = Replace(s, "_" & vbCrLf, Chr(133) & vbLf)
' 4. define logical line entities
If Right(s, 2) = vbCrLf Then s = Left(s, Len(s) - 2)
s = HEAD & " <line>" & Replace(s, vbCrLf, "</line>" & vbCrLf & " <line>") & "</line>" & vbCrLf & "</cm>"
' debug xml tags if second function parameter is true (mode = True)
If mode Then Debug.Print s
' return
getTags = s
End Function
Sub testErlPosInLine()
' Purpose: Test Thunderframe's problem with ERL prefixes (underscores, " ",..) and hex inputs
Dim s As String
s = " _" & vbLf & " -1 xx"
MsgBox "|" & Mid(s, ErlPosInLine(s)) & "|" & vbNewLine & _
"prefix = |" & Mid(s, 1, ErlPosInLine(s) - 1) & "|"
End Sub
Private Function ErlPosInLine(ByVal s As String) As Integer
' Purpose: remove prefix (underscore, tab, " ",.. ) from numbered line
' cf: http://stackoverflow.com/questions/42716936/vba-to-remove-numbers-from-start-of-string-cell
Dim i As Long
For i = 1 To Len(s) ' loop each char
Select Case Mid$(s, i, 1) ' examine current char
Case " " ' permitted chars
Case "_"
Case vbLf, Chr(133), Chr(34)
Case "0" To "9": Exit For ' cut off point
Case Else: Exit For ' i is the cut off point
End Select
Next
If Mid$(s, i, 1) = "-" And Len(s) > 1 Then
If IsNumeric(Mid$(s, i + 1, 1)) Then i = i + 1
End If
' return
ErlPosInLine = i
' debug.print Mid$(s, i) '//strip lead
End Function

Related

Modify matrix column spacing in equation through Word VBA

I would like to automate vertically stacked math problems (sums, products, etc.).
By using matrices I can align the numbers to the right so the digits align.
However, the column spacing default is too wide:
I can manually right click the matrix, select matrix spacing and set the minimum distance between columns to exactly 1, achieving my goal:
I cannot get the syntax of the matrix manipulation in VBA. The documentation seems very sparse (no examples). I tried recording a macro, but the right-click menu does not appear for the matrix in the equation when recording. I am not sure how to "set" the OMathMat object, since it is not a property of OMath.
I would settle for code that looped through all the equation objects in the document, all the matrix objects in those equations, and updated the OMathMat.ColSpacing property.
I tried something like:
For Each equation In ActiveDocument.OMaths
For Each Func In equation.Functions
Func.Mat.ColSpacing = 1
Next
Next
But the requested member (Mat) of the collection (Functions) did not exist. Also, there seems to be OMathFunction.Mat and OMathMat. I think I need the second option.
I agree that there isn't an obvious place to find documentation about accessing the OMath objects, so started trying to put something together.
But then you answered your own question - at this point it's probably more useful to publish what I already have, despite the fact that there are many unanswered questions.
So here are a few pieces of code that may help shed some light. They aren't well-tested.
I may well try to improve this question in future, but it will take time.
The first set of code should be able to deal with the situation where your Matrix objects could be anywhere in an OMath object.
The second set of code implements an "explorer" that reports the structure of the OMath objects in the main body of the document via Debug.Print statements.
Then there are a few more notes at the end.
Here's the code that should do what you needed, but slightly more generalised. You can copy the code into a single Module and run it.
' Keep some running totals
Dim OMathCount As Integer
Dim FunctionCount As Long
Dim MatCount As Long
Sub processOMaths()
Dim i As Long
FunctionCount = 0
MatCount = 0
' Just process the document body
With ActiveDocument
For i = 1 To .OMaths.Count
With .OMaths(i)
Call processOMathFunctions(.Functions)
End With
OMathCount = i
Next
End With
MsgBox "Processed " & CStr(OMathCount) & " Equation(s), " & _
CStr(FunctionCount) & " Function(s), " & _
CStr(MatCount) & " Matrix object(s)"
End Sub
Sub processOMathFunctions(oFunctions As OMathFunctions)
' There does not seem to be a way to return the entire collection of Functions
' in an OMath object. So it looks as if we have to recurse. But because the
' Object names for different Functions are different, we can't easily drill down
' to the next level using exactly the same code for multiple object types...
Dim i As Integer
For i = 1 To oFunctions.Count
Call processSingleOMathFunction(oFunctions, i)
Next
End Sub
Sub processSingleOMathFunction(oFunctions As OMathFunctions, index As Integer)
' ...so unless someone has a better idea, we'll just use a Select Case
' statement and deal with all the possible Function types
FunctionCount = FunctionCount + 1
With oFunctions(index)
Select Case .Type
Case WdOMathFunctionType.wdOMathFunctionAcc
Call processOMathFunctions(.Acc.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionBar
Call processOMathFunctions(.Bar.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionBorderBox
Call processOMathFunctions(.BorderBox.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionBox
Call processOMathFunctions(.Box.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionDelim
Dim delimCount As Integer
For delimCount = 1 To .Delim.E.Count
Call processOMathFunctions(.Delim.E(1).Functions)
Next
Case WdOMathFunctionType.wdOMathFunctionEqArray
Dim eqCount As Integer
For eqCount = 1 To .EqArray.E.Count
Call processOMathFunctions(.EqArray.E(eqCount).Functions)
Next
Case WdOMathFunctionType.wdOMathFunctionFrac
Call processOMathFunctions(.Frac.Num.Functions)
Call processOMathFunctions(.Frac.Den.Functions)
Case WdOMathFunctionType.wdOMathFunctionFunc
Call processOMathFunctions(.Func.E.Functions)
Call processOMathFunctions(.Func.FName.Functions)
Case WdOMathFunctionType.wdOMathFunctionGroupChar
Call processOMathFunctions(.GroupChar.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionLimLow
Call processOMathFunctions(.LimLow.E.Functions)
Call processOMathFunctions(.LimLow.Lim.Functions)
Case WdOMathFunctionType.wdOMathFunctionLimUpp
Call processOMathFunctions(.LimUpp.E.Functions)
Call processOMathFunctions(.LimUpp.Lim.Functions)
Case WdOMathFunctionType.wdOMathFunctionLiteralText
' as far as I know, this cannot contain further Functions
' Do nothing.
Case WdOMathFunctionType.wdOMathFunctionMat
MatCount = MatCount + 1
Dim i As Integer
.Mat.ColGapRule = wdOMathSpacingExactly
' Hardcode this bit
.Mat.ColGap = 1 ' I think these are Twips, i.e. 1/20 pt
' We could iterate the columns and rows, but
' we'll iterate the Args instead.
For i = 1 To .Args.Count
Call processOMathFunctions(.Args(i).Functions)
Next
Case WdOMathFunctionType.wdOMathFunctionNary
Call processOMathFunctions(.Nary.Sub.Functions)
Call processOMathFunctions(.Nary.Sup.Functions)
Call processOMathFunctions(.Nary.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionNormalText
' Used for 'Non-Math text'
' Do nothing
Case WdOMathFunctionType.wdOMathFunctionPhantom
Call processOMathFunctions(.Phantom.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionRad
Call processOMathFunctions(.Rad.Deg.Functions)
Call processOMathFunctions(.Rad.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionScrPre
Call processOMathFunctions(.ScrPre.Sub.Functions)
Call processOMathFunctions(.ScrPre.Sup.Functions)
Call processOMathFunctions(.ScrPre.E.Functions)
Case WdOMathFunctionType.wdOMathFunctionScrSub
Call processOMathFunctions(.ScrSub.E.Functions)
Call processOMathFunctions(.ScrSub.Sub.Functions)
Case WdOMathFunctionType.wdOMathFunctionScrSubSup
Call processOMathFunctions(.ScrSubSup.E.Functions)
Call processOMathFunctions(.ScrSubSup.Sub.Functions)
Call processOMathFunctions(.ScrSubSup.Sup.Functions)
Case WdOMathFunctionType.wdOMathFunctionScrSup
Call processOMathFunctions(.ScrSup.E.Functions)
Call processOMathFunctions(.ScrSup.Sup.Functions)
Case WdOMathFunctionType.wdOMathFunctionText
' Text - do nothing
Case Else
MsgBox "OMath Function type " & CStr(.Type) & " not recognized. Ignoring."
End Select
End With
End Sub
The second lot of code is the Explorer. It's incomplete, in various ways. All the code could go in a single Module but as it stands it is divided into three Modules:
One module contains the main Explorer code, which is structured in a similar way to the code I posted above. I haven't completed the code for all the function types so you will see some TBD (To Be Done) comments.
' indentation increment for each level of oMath object nesting
Const incindent As String = " "
Sub exploremath()
' This code explores the structure of 'modern' equations in Word
' i.e. the sort that have neen in Word since around Word 2007, not the older
' types inserted using an ActiveX object or an EQ field.
' Note to English speakers: some places use "Math" to refer to Mathematics
' e.g. the US. Others, e.g. the UK, use "Maths". This can cause a bit of confusion
' for UK English speakers but the trick is to realise that the oMaths object
' is just a collection of oMath objects. i.e. the naming convention is exactly the same as
' e.g. Paragraphs/Paragraph and so on.
' The overview is that
' - each Equation is represented by an OMath object
' - an oMath object contains an oMathFunctions collection
' with 0 (?1) or more oMathFunction objects
' - an oMathFunction object can represent several different
' types of structure, not just those with familiar function names
' such as Sin, Cos etc. but structures such as Matrices,
' Equation Arrays and so on.
Dim eqn As oMath
Dim fn As OMathFunction
Dim i As Long
Dim j As Long
Dim indent As String
With ActiveDocument
For i = 1 To .OMaths.Count
With .OMaths(i)
Debug.Print "Equation " & CStr(i) & ":-"
indent = ""
Call documentOMathFunctions(.Functions, indent)
End With
Debug.Print
Next
End With
End Sub
Sub documentOMathFunctions(fns As OMathFunctions, currentindent As String)
Dim i As Integer
Dim indent As String
indent = currentindent & incindent
Debug.Print indent & "Function count: " & CStr(fns.Count)
For i = 1 To fns.Count
Call documentOMathFunction(fns, i, indent)
Debug.Print
Next
End Sub
Sub documentOMathFunction(fns As OMathFunctions, index As Integer, currentindent As String)
Dim indent As String
indent = currentindent & incindent
With fns(index)
Debug.Print indent & "Function " & CStr(index) & ", Type: " & OMathFunctionTypeName(.Type) & " :-"
Select Case .Type
Case WdOMathFunctionType.wdOMathFunctionAcc
' Accented object
Debug.Print indent & "Accent: " & debugPrintString(ChrW(.Acc.Char))
Call documentOMathFunctions(.Acc.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionBar
' object with an overbar
Debug.Print indent & "Bar " & AB(.Bar.BarTop) & ":-"
Call documentOMathFunctions(.Bar.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionBorderBox
' TBD
Case WdOMathFunctionType.wdOMathFunctionBox
Debug.Print indent & "Box: IsDifferential? " & YN(.Box.Diff) & _
", Breaks Allowed? " & YN(Not .Box.NoBreak) & _
", TreatAsSingleOp? " & YN(.Box.OpEmu)
Call documentOMathFunctions(.Box.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionDelim
' Brackets etc.
Debug.Print indent & "Delim: BeginningChar: " & _
debugPrintString(ChrW(.Delim.BegChar)) & _
", EndChar: " & debugPrintString(ChrW(.Delim.EndChar)) & _
", SeparatorChar: " & debugPrintString(ChrW(.Delim.SepChar))
Debug.Print indent & incindent & "Grow? " & _
YN(.Delim.Grow) & ", LeftChar Hidden? " & _
YN(.Delim.NoLeftChar) & ", RightChar Hidden? " & _
YN(.Delim.NoRightChar) & ", Appearance: " & OMathShapeTypeName(.Delim.Shape)
Dim delimCount As Integer
For delimCount = 1 To .Delim.E.Count
Debug.Print indent & "Part " & CStr(delimCount) & ":-"
Call documentOMathFunctions(.Delim.E(1).Functions, indent)
Next
Case WdOMathFunctionType.wdOMathFunctionEqArray
' Array of aligned equations
Debug.Print indent & "Equation Array: Vertical Alignment : " & OMathVertAlignTypeName(.EqArray.Align) & _
", Expand to page column width? " & YN(.EqArray.MaxDist)
Debug.Print "Expand to object width? " & YN(.EqArray.ObjDist) & _
", Row Spacing Rule: " & oMathSpacingRuleName(.EqArray.RowSpacingRule);
If .EqArray.RowSpacingRule = WdOMathSpacingRule.wdOMathSpacingExactly Then
Debug.Print ", Row Spacing: " & CStr(.EqArray.RowSpacing) & " twips"
ElseIf .EqArray.RowSpacingRule = WdOMathSpacingRule.wdOMathSpacingMultiple Then
' Don't know what the .rowspacing Unit is in this case
Debug.Print ", Row Spacing: " & CStr(.EqArray.RowSpacing) & " half-lines";
End If
Debug.Print
Dim eqCount As Integer
For eqCount = 1 To .EqArray.E.Count
Debug.Print indent & "Equation " & CStr(eqCount) & ":-"
Call documentOMathFunctions(.EqArray.E(eqCount).Functions, indent)
Next
Case WdOMathFunctionType.wdOMathFunctionFrac
' Fraction
Debug.Print indent & "Fraction numerator:-"
Call documentOMathFunctions(.Frac.Num.Functions, indent)
Debug.Print indent & "Fraction denominator:-"
Call documentOMathFunctions(.Frac.Den.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionFunc
' Function (not sure yet whether a 'Func' can
' only have a single argument (possibly blank))
Debug.Print indent & "Func name: " & debugPrintString(.Func.FName.Range.Text)
Call documentOMathFunctions(.Func.E.Functions, indent)
Call documentOMathFunctions(.Func.FName.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionGroupChar
' A character such as a brace over or under another Function.
Debug.Print indent & "Group Char: " & UHex(.GroupChar.Char) & ", Position: " & AB(.GroupChar.CharTop); ""
Call documentOMathFunctions(.GroupChar.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionLimLow
' A Limit with the small text under the 'Lim word'
Debug.Print indent & "'LimLow':-"
Debug.Print indent & "Base:-"
Call documentOMathFunctions(.LimLow.E.Functions, indent)
Debug.Print indent & "Lim:-"
Call documentOMathFunctions(.LimLow.Lim.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionLimUpp
' A limit with the small text over the 'Lim word'
Debug.Print indent & "'LimUpp':-"
Debug.Print indent & "Base:-"
Call documentOMathFunctions(.LimUpp.E.Functions, indent)
Debug.Print indent & "Lim:-"
Call documentOMathFunctions(.LimUpp.Lim.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionLiteralText
' 'Literal Text' at first sight seems to be followed by
' a wdOMathFunctionText function with a Range
' containing the actual text.
' To be explored further
' But for now, do nothing.
Case WdOMathFunctionType.wdOMathFunctionMat
' A Matrix. AFAIK they have to be rectangular
Dim i As Integer
Debug.Print indent & ", Column count: " & CStr(.Mat.Cols.Count) & _
", Column gap rule: " & oMathSpacingRuleName(.Mat.ColGapRule);
If .Mat.ColGapRule = WdOMathSpacingRule.wdOMathSpacingExactly Then
Debug.Print ", Spacing: " & CStr(.Mat.ColGap) & " twips";
ElseIf .Mat.ColGapRule = WdOMathSpacingRule.wdOMathSpacingMultiple Then
Debug.Print ", Spacing: " & CStr(.Mat.ColGap);
End If
Debug.Print
Debug.Print indent & "Row count: " & CStr(.Mat.Rows.Count) & _
", Row gap rule: " & oMathSpacingRuleName(.Mat.RowSpacingRule);
If .Mat.RowSpacingRule = WdOMathSpacingRule.wdOMathSpacingExactly Then
Debug.Print ", Spacing: " & CStr(.Mat.RowSpacing) & " twips";
End If
Debug.Print
Debug.Print indent & "Args count: " & CStr(.Args.Count)
For i = 1 To .Args.Count
Debug.Print indent & " Arg " & CStr(i) & ":-"
Call documentOMathFunctions(.Args(i).Functions, indent)
Next
Case WdOMathFunctionType.wdOMathFunctionNary
' An N-Ary function, such as a summation operator, product operator
' various types of integral operator and so on.
' AFAICS all current N-Ary operators are in effect 3-Ary, i.e.
' The lower limit is the Sub, the upper limit is the Sup, and the
' thing being summed/integrated etc. is the 'Base'
' ignore .SubSupLim for now
.Nary.Char = &H2AFF
Debug.Print indent & "N-ary function, Type character: " & _
oMathNaryOpName(.Nary.Char) & ", Grow? " & YN(.Nary.Grow) & ":-"
Debug.Print indent & "N-ary Lower limit:- Hidden? " & YN(.Nary.HideSub)
Call documentOMathFunctions(.Nary.Sub.Functions, indent)
Debug.Print indent & "N-ary Upper limit:- Hidden? " & YN(.Nary.HideSup)
Call documentOMathFunctions(.Nary.Sup.Functions, indent)
Debug.Print indent & "N-ary body:-"
Call documentOMathFunctions(.Nary.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionNormalText
'Used for 'Non-Math text'
Debug.Print indent & "Literal Text: " & debugPrintString(.Range.Text)
Case WdOMathFunctionType.wdOMathFunctionPhantom
' TBD
Case WdOMathFunctionType.wdOMathFunctionRad
Debug.Print indent & "Degree:- (Hidden? " & YN(.Rad.HideDeg)
Call documentOMathFunctions(.Rad.Deg.Functions, indent)
Debug.Print indent & "Radical:-"
Call documentOMathFunctions(.Rad.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionScrPre
' base object with a superscript/subscript *before* the base
' Think this means an obect that has *both* (although one or both
' could be left blank)
' (TBR: Can OMath be used right-to-left, and if so, how
' are properties named/documented as 'to the left of',
' 'to the right of', 'before', 'after' to be interpreted?
' Or are math formulas etc. always expressed as LTR worldwide
' these days (I would guess so!)
Debug.Print indent & "ScrPre Subscript:-"
Call documentOMathFunctions(.ScrPre.Sub.Functions, indent)
Debug.Print indent & "ScrPre Superscript:-"
Call documentOMathFunctions(.ScrPre.Sup.Functions, indent)
Debug.Print indent & "ScrPre Base-"
Call documentOMathFunctions(.ScrPre.E.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionScrSub
' base object with a subscript after the base
Debug.Print indent & "Base:-"
Call documentOMathFunctions(.ScrSub.E.Functions, indent)
Debug.Print indent & "Superscript:-"
Call documentOMathFunctions(.ScrSub.Sub.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionScrSubSup
' base object with subscript and supersript after the base
Debug.Print indent & "ScrSubSup Base-"
Call documentOMathFunctions(.ScrSubSup.E.Functions, indent)
Debug.Print indent & "ScrSubSup Subscript:-"
Call documentOMathFunctions(.ScrSubSup.Sub.Functions, indent)
Debug.Print indent & "ScrSubSup Superscript:-"
Call documentOMathFunctions(.ScrSubSup.Sup.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionScrSup
' base object with supersript after the base
Debug.Print indent & "Base:-"
Call documentOMathFunctions(.ScrSup.E.Functions, indent)
Debug.Print indent & "Superscript:-"
Call documentOMathFunctions(.ScrSup.Sup.Functions, indent)
Case WdOMathFunctionType.wdOMathFunctionText
Debug.Print indent & "Text: " & debugPrintString(getRunTextFromXML(.Range))
Case Else
' we already printed an unknown type message before the select statement.
End Select
End With
End Sub
In Module "Common" there are some Helper routines
usly had Cstr
Function UHex(codepoint As Long) As String
' Form a 4-digit Unicode Hex string
' fix : had 'CStr' instead of 'Hex'
UHex = "U+" & Right("0000" & Hex(codepoint), 4)
End Function
Function debugPrintString(s As String) As String
' Form a string where 1-byte characters are output as is,
' others are output as Unicode Hex strings
' NB, at the moment we do not try to change stuff such as "&" to "&"
Dim i As Long
Dim t As String
t = ""
For i = 1 To Len(s)
If AscW(Mid(s, i, 1)) < 256 Then
t = t & Mid(s, i, 1)
Else
t = t & " " & UHex(AscW(Mid(s, i, 1))) & " "
End If
Next
debugPrintString = t
End Function
Function YN(b As Boolean) As String
If b Then YN = "Y" Else YN = "N"
End Function
Function AB(b As Boolean) As String
If b Then AB = "Above" Else AB = "Below"
End Function
Function getRunTextFromXML(r As Word.Range) As String
' We need a function like this to retrieve text in the Math Font, (e.g. Cambria Math Font,
' which appears to be encoded as ASCII rather than Unicode.
' So if the equation contains a Cambria Math "A", the .Range.Text is returned as "??"
' For later: if the text is *not* in Cambria Math, we probably *don't* want to do this!
' (Could end up inspecting character by character).
' For the moment, use a kludge to get the first run of text in the range.
Dim x As String
Dim i1 As Long
Dim i2 As Long
x = r.WordOpenXML
' FOr an oMath text, we look for m:t rather than w:t
i1 = InStr(1, x, "<m:t>")
i2 = InStr(i1, x, "</m:t>")
getRunTextFromXML = Mid(x, i1 + 5, i2 - i1 - 5)
End Function
In module Enums, there are some more Helper routines to return things such as Enum names as text (if only VBA had better facilities for Reflection!)
Function oMathIsAllowedNaryOp(codepoint As Long) As Boolean
' Perhaps can look up the unicode database rather than hardcode this list
Select Case codepoint
Case &H2140, &H220F To &H2211, &H222B To &H2233, &H22C0 To &H22C3, &H2A00 To &H2A06, &H2A09, &H2AFF
oMathIsAllowedNaryOp = True
Case Else
oMathIsAllowedNaryOp = False
End Select
End Function
Function oMathNaryOpName(codepoint As Long) As String
' Perhaps can look up the unicode database rather than hardcode this list
' and the standard Unicode character names
Select Case codepoint
Case &H2104
oMathNaryOpName = "Double-Struck N-Ary Summation"
Case &H220F
oMathNaryOpName = "N-Ary Product"
Case &H2210
oMathNaryOpName = "N-Ary Coproduct"
Case &H2211
oMathNaryOpName = "N-Ary Summation"
Case &H22C0
oMathNaryOpName = "N-Ary Logical And"
Case &H22C1
oMathNaryOpName = "N-Ary Logical Or"
Case &H22C2
oMathNaryOpName = "N-Ary Intersection"
Case &H22C3
oMathNaryOpName = "N-Ary Union"
Case &H22A0
oMathNaryOpName = "N-Ary Circled Dot Operator"
Case &H22A1
oMathNaryOpName = "N-Ary Circled Plus Operator"
Case &H22A2
oMathNaryOpName = "N-Ary Circled Times Operator"
Case &H22A3
oMathNaryOpName = "N-Ary Union Operator With Dot"
Case &H22A4
oMathNaryOpName = "N-Ary Union Operator With Plus"
Case &H22A5
oMathNaryOpName = "N-Ary Square Intersection Operator"
Case &H22A6
oMathNaryOpName = "N-Ary Square Union Operator"
Case &H22A9
oMathNaryOpName = "N-Ary Times Operator"
Case &H2AFF
oMathNaryOpName = "N-Ary White Vertical Bar"
Case Else
oMathNaryOpName = "(Possibly invalid N-ary opcode: " & UHex(codepoint) & ")"
End Select
End Function
Function OMathShapeTypeName(OMathShapeType As Integer) As String
Select Case OMathShapeType
Case WdOMathShapeType.wdOMathShapeCentered
OMathShapeTypeName = "wdOMathShapeCentered"
Case WdOMathShapeType.wdOMathShapeMatch
OMathShapeTypeName = "wdOMathShapeMatch"
Case Else
OMathShapeTypeName = "(Math Shape Type unknown: " & CStr(OMathShapeType) & ")"
End Select
End Function
Function oMathSpacingRuleName(oMathSpacingRule As Long) As String
Select Case oMathSpacingRule
Case WdOMathSpacingRule.wdOMathSpacing1pt5
oMathSpacingRuleName = "wdOMathSpacing1pt5"
Case WdOMathSpacingRule.wdOMathSpacingDouble
oMathSpacingRuleName = "wdOMathSpacingDouble"
Case WdOMathSpacingRule.wdOMathSpacingExactly
oMathSpacingRuleName = "wdOMathSpacingExactly"
Case WdOMathSpacingRule.wdOMathSpacingMultiple
oMathSpacingRuleName = "wdOMathSpacingMultiple"
Case WdOMathSpacingRule.wdOMathSpacingSingle
oMathSpacingRuleName = "wdOMathSpacingSingle"
Case Else
oMathSpacingRuleName = "(Math Spacing Rule unknown: " & CStr(oMathSpacingRule) & ")"
End Select
End Function
Function OMathVertAlignTypeName(OMathVertAlignType As Integer) As String
Select Case OMathVertAlignType
Case WdOMathVertAlignType.wdOMathVertAlignBottom
OMathVertAlignTypeName = "wdOMathVertAlignBottom"
Case WdOMathVertAlignType.wdOMathVertAlignCenter
OMathVertAlignTypeName = "wdOMathVertAlignCenter"
Case WdOMathVertAlignType.wdOMathVertAlignTop
OMathVertAlignTypeName = "wdOMathVertAlignTop"
Case Else
OMathVertAlignTypeName = "(Math Vertical Alignment Type unknown: " & CStr(OMathVertAlignType) & ")"
End Select
End Function
Notes.
AFAIK the author/designer of the OMath objects and User Interface
(and indeed other aspect of layout in Word) is Murray Sargent III.
His paper on UnicodeMath Describes how the system as a whole is
intended to use Build-Up. But take care, because not everything
mentioned in there is necessarily implemented in all versions of
OMath (which is used across a number of MS Office products). His
Math-in-Office blog can be quite enlightening too.
There are at least two versions of the OMath object documentation -
one for "VBA" and one for .NET. There are some differences (e.g. some
Properties and at least one Function Type enumeration name is missing
from the VBA version. The .NET version is near here and the VBA
version is near here.
At the moment, none of the code I've posted provides anything that would help you modify the Function structure of an Equation, e.g. insert a new function. That's mainly because I haven't got to grips with it yet. Even writing code to insert a piece of Text throws up a number of problems, not least the question of why Math Font text is not encoded as Unicode and what that means when it comes to modifying it. It may in fact be easier to work with the Linear ("not built up" text version rather than the Object model. TBD!
I solved my problem, looping through the equations (OMaths collection), and then, using the WdOMathFunctionType enumeration to find fraction type functions that contained a matrix in their numerator, I could properly set the matrix properties:
For Each eq In ActiveDocument.OMaths
For Each Func In eq.Functions
If Func.Type = 7 Then 'a fraction function
If Func.Args(1).Functions(1).Type = 12 Then 'a matrix function in the numerator
With Func.Args(1).Functions(1).Mat
.ColGapRule = wdOMathSpacingExactly
.ColGap = 1
.PlcHoldHidden = True
End With
End If
End If
Next
Next
I knew the type of structured equations my document contained, so I didn't include many check conditions. (There probably a more elegant and robust way to search all 'child functions' of equations until the last node is reached.) Hopefully this can serve as a template for anyone trying to expose specific OMath Function properties.

MS Access VBA - Loop Split Function and Output Either First Value (If Not Null) or Last Value

I have a field in my Access database that contains values such as 24,25,152, 128,152, ,113, 113 and NULLS.
When there is only one value present in the field I would like the first value to be my output (113 for ,113 and 113) and when there is more than one value present I would like the last value to be my output (152 for 24,25,152 and 128,152).
Right now I have a user-defined function that is invoked by a query that has been hard-coded to account for the correct number of commas/values present in the field. In the future there will be more commas so I would like to account for those and I'd like my output to be in a single column (as opposed to having one column per value after each comma).
Here is VBA code for that user-defined function which came from this post.
Function mySplit(sMyText As String, sDelim As String, lIndx As Long) As String
On Error GoTo Error_Handler
mySplit = Split(sMyText, sDelim)(lIndx)
Error_Handler_Exit:
On Error Resume Next
Exit Function
Error_Handler:
If Err.Number = 9 Then
mySplit = ""
Else
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: mySplit" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Function
Here is the query:
SELECT Field, mySplit([field].[table],",",0) AS 1, mySplit([field].[table],",",1) AS 2, mySplit([field].[table],",",2) AS 3, Val(IIf([3]<>"",[3],IIf([2]<>"",[2],IIf([1]<>"",[1])))) AS [Value]
FROM Table;
Ideally I'd to have a single field that looks like the "Value" field (outlined in green) in the image below.
Right now that value field is a bunch of nested if statements looking at the 1, 2, and 3 columns. I know I need to modify this code to count the delimiters and then loop through each delimiter and take either the first value (if there is only one) and the last value (if there is more than one) but I am not sure how to go about achieving that.
Any help will be greatly appreciated.
EDIT
Try this.
Just Split the value and return the last element in the array. If the value is null, return an empty string.
Public Function SplitToLast(Value As Variant) As String
On Error GoTo Trap
If IsNull(Value) Then GoTo Leave
Dim arr As Variant
arr = Split(Value, ",")
SplitToLast = arr(UBound(arr))
Leave:
On Error GoTo 0
Exit Function
Trap:
MsgBox Err.Description, vbCritical
Resume Leave
End Function
Try this:
Public Function GetLastValue(ByVal value As Variant, ByVal delimiter As String) As String
If IsNull(value) Then Exit Function
If Len(delimiter) = 0 Then
GetLastValue = value
Exit Function
End If
Dim tmpValue As String
tmpValue = Trim(CStr(value))
Do While tmpValue Like "*" & delimiter
tmpValue = Trim(Left(tmpValue, Len(tmpValue) - Len(delimiter)))
Loop
If Len(tmpValue) = 0 Then Exit Function
Dim tmpArr() As String
tmpArr = Split(tmpValue, delimiter)
GetLastValue = tmpArr(UBound(tmpArr))
End Function
It also takes care of multiple delimiters at the end of the value like 1,2,3,, ,.
It also works if the length of the delimiter is > 1.
In case value is an empty string, the result will be an empty string too.
In case delimiter is an empty string, the result will be value.
This example calling works fine:
SELECT GetLastValue([Field1],",") AS LastValue FROM Table1
If you edit the query in the query design view and not in SQL view, take care of the , which separates the parameters. There it must be a ; instead.

Inputbox is not accepting double number VBA excel

I have a declaration like number= InputBox("Number for:", "Number:"), number is declared as Dim number As Double but when I enter a double number, for example 5.4, into the Inputbox and transmit it into a cell, the cell shows me 54, it deletes the point.
How can I fix this?
THX
If you want to detect which settings your Excel uses for the Decimal seperator, try the code below:
MsgBox "Excel uses " & Chr(34) & Application.DecimalSeparator & Chr(34) & " as a decimal seperator"
if you want to change it to ., then use the line below:
Application.DecimalSeparator = "."
Unfortunately, VBA is horrible at handling differences in decimal seprators. In your case, you should probably use a comma (,), instead of a punctuation/dot (.).
Edit: Using the Application.DecimalSeparator method, it now works regardless of regional settings. Be aware though, it seems to cause some issues if you change the comma separator settings for Excel (it seems that VBA somewhat ignores this setting). If you do not change that however, the example should work in all other cas
Sub GetNumberFromInputBox()
Dim val As String
Dim num As Double
'Get input
val = InputBox("Number for:", "Number:")
Debug.Print Application.DecimalSeparator
If IsNumeric(val) Then
'Try to convert to double as usual
num = CDbl(val)
'If the dot is removed automatically, then
'you will se a difference in the length. In
'those cases, replace the dot with a comma,
'before converting to double
If Len(val) <> Len(num) Then
If Application.DecimalSeparator = "," Then
num = CDbl(Replace(val, ".", ","))
Else
num = CDbl(Replace(val, ",", "."))
End If
End If
'Pring the number
Debug.Print "You selected number: " & num
Else
'If its not a number at all, throw an error
Debug.Print "You typed " & val & ", which is not a number"
End If
End Sub

Generic Way to Determine the Maximum Allowed Length a of String

Take a look at this property(Given you have a table on the first worksheet):
Application.Sheets(1).ListObjects(1).name
How many characters can this property contain? Well, after testing out a few strings I've come to the conclusion that its 255, any string with more than 255 characters causes an error to be thrown:
Run-Time Error 5 - Invalid procedure call or arguement
Take a look at this property:
Application.Sheets(1).ListObjects(1).Summary
How many characters can this property contain? Again, test several strings and you'll come out with a number that's around 50,000, You set it any higher and you get the same error, except in this case excel will sometimes crash or spit out a different error(after multiple attempts):
Dim i As Integer
Dim a As String
For i = 1 To 5001
a = a & "abcdefghih"
Next i
Application.Sheets(1).ListObjects(1).Summary = a
Method "Summary" of object 'ListObject' failed
This sort of "hidden" character limit comes up all over the place(here, here, less specifically here, and so classically here), and it doesn't seem like they're documented anywhere, for example take a look at the page for ListObject.Name, its not noted how many characters you can store in that variable...
So is there a better way to determine this? Are the strings you are setting in properties being stored in a fixed length string somewhere that can be accessed to determine what their maximum length is, or is there some other form of documentation that can be leveraged in order to obtain this information?
It strikes me as odd these character limits that are set on most strings within standard VBA objects, I wonder what their purpose is, why the designers choose to limit "ListObjects.name" to 255 characters and whether that was an arbitrary default limit or whether that was a conscious decision that was made. I believe that the standard string length is this, I wonder why the deviation from this standard.
To summarize the points I've made above and to condense this question into one sentence:
Is there a generic way to determine the maximum length of a string that can be set within an object's property, without first testing that string's property by giving it another value and ignoring errors/checking for character truncation?
First of all, if your intention is to store meta information about objects, you could maybe make use of CustomDocumentProperties. You can find examples on their usage here and here and some nice wrappers by Chip Pearson here.
Since they are still very limited (255 chars) in length (thanks for pointing that out!), the best solution might be to use CustomXMLParts like described here. The hard part would then be building correct XML using VBA, but maybe not impossible, if you add a reference to Microsoft XML.
But to provide some help with your question concerning maximum lengths for string properties, too, here is a test setup you can use to (relatively) quickly find these limits for arbitrary properties.
Just replace the ActiveWorkbook.Sheets(1).Name on line 19 with the property you want to test and run TestMaxStringLengthOfProperty():
Option Explicit
Const PRINT_STEPS = True ' If True, calculation steps will be written to Debug.Print
Private Function LengthWorks(ByVal iLengthToTest As Long) As Boolean
Dim testString As String
testString = String(iLengthToTest, "#") ' Build string with desired length
' Note: The String() method failed for different maximum string lengths possibly
' depending on available memory or other factors. You can test the current
' limit for your setup by putting the string assignment in the test space.
' In my tests I found maximum values around 1073311725 to still work.
On Error Resume Next
' ---------------------------------------------------------------------------------
' Start of the Test Space - put the method/property you want to test below here
ActiveWorkbook.Sheets(1).Name = testString
' End of the Test Space - put the method/property you want to test above here
' ---------------------------------------------------------------------------------
LengthWorks = Err.Number = 0
On Error GoTo 0
End Function
Private Sub TestMaxStringLengthOfProperty()
Const MAX_LENGTH As Long = 1000000000 ' Default: 1000000000
Const MAXIMUM_STEPS = 100 ' Exit loop after this many tries, at most
' Initialize variables for check loop
Dim currentLength As Long
Dim lowerBoundary As Long: lowerBoundary = 0
Dim upperBoundary As Long: upperBoundary = MAX_LENGTH
Dim currentStep As Long: currentStep = 0
While True ' Infinite loop, will exit sub directly
currentStep = currentStep + 1
If currentStep > MAXIMUM_STEPS Then
Debug.Print "Exiting because maximum number of steps (" & _
CStr(MAXIMUM_STEPS) & _
") was reached. Last working length was: " & _
CStr(lowerBoundary)
Exit Sub
End If
' Test the upper boundary first, if this succeeds we don't need to continue search
If LengthWorks(upperBoundary) Then
' We have a winner! :)
Debug.Print "Method/property works with the following maximum length: " & _
upperBoundary & vbCrLf & _
"(If this matches MAX_LENGTH (" & _
MAX_LENGTH & "), " & _
"consider increasing it to find the actual limit.)" & _
vbCrLf & vbCrLf & _
"Computation took " & currentStep & " steps"
Exit Sub
Else
' Upper boundary must be at least one less
upperBoundary = upperBoundary - 1
PrintStep upperBoundary + 1, "failed", lowerBoundary, upperBoundary, MAX_LENGTH
End If
' Approximately halve test length
currentLength = lowerBoundary + ((upperBoundary - lowerBoundary) \ 2)
' "\" is integer division (http://mathworld.wolfram.com/IntegerDivision.html)
' Using `left + ((right - left) \ 2)` is the default way to avoid overflows
' when calculating the midpoint for our binary search
' (see: https://en.wikipedia.org/w/index.php?title=Binary_search_algorithm&
' oldid=809435933#Implementation_issues)
If LengthWorks(currentLength) Then
' If test was successful, increase lower boundary for next step
lowerBoundary = currentLength + 1
PrintStep currentLength, "worked", lowerBoundary, upperBoundary, MAX_LENGTH
Else
' If not, set new upper boundary
upperBoundary = currentLength - 1
PrintStep currentLength, "failed", lowerBoundary, upperBoundary, MAX_LENGTH
End If
Wend
End Sub
Private Sub PrintStep(ByVal iCurrentValue As Long, _
ByVal iWorkedFailed As String, _
ByVal iNewLowerBoundary As Long, _
ByVal iNewUpperBoundary As Long, _
ByVal iMaximumTestValue As Long)
If PRINT_STEPS Then
Debug.Print Format(iCurrentValue, String(Len(CStr(iMaximumTestValue)), "0")) & _
" " & iWorkedFailed & " - New boundaries: l: " & _
iNewLowerBoundary & " u: " & iNewUpperBoundary
End If
End Sub
The short answer is no.
Regards, Zack Barresse

VBA optimization robust code

So I'm completely new to VBA. I have a java-fetish so I'm not new to programming, however manipulating office documents just seemed easier with VBA.
Anyway, on topic:
I'm currently automating things in the company (This example is creating a contract). However, using Java, I always learned to make robust code and although the VBA code now works, I'm not happy with it because it requires a lot of 'friendliness' of the user. So my question is (I hope you don't mind), could you give me a nudge in the right direction to make my code way more robust?
Here's the code:
Function spaties(Name As String) As String
' Function used to ensure the length of a String (Working with Range)
Dim index As Integer
While (Len(Name) < 30)
Name = Name + " "
Wend
spaties = Name
End Function
Sub Macro3()
'
' Macro3 Macro
'
'
'ActiveDocument.Range(26101, 26102).Text = "d"
StartUndoSaver
Dim firma As String
firma = InputBox("Voor welke onderaannemer? (Zonder hoofdletters)" + Chr(10) + "(nicu, sorin of marius)")
Dim werf As String
werf = InputBox("Over welke Werf gaat het?")
Dim datum As String
datum = InputBox("Op welke datum spreekt het contract? (dd/mm/yyyy)")
With ActiveDocument
.Range(25882, 25899).Text = datum
ActiveDocument.Range(575, 605).Text = spaties(werf)
ActiveDocument.Range(1279, 1309).Text = spaties(werf)
End With
Select Case Len(firma)
Case 4
With ActiveDocument
.Range(26168, 26181).Text = "Nicu Dinita"
.Range(26062, 26088).Text = "Badi Woodconstruct SRL"
.Range(11359, 11371).Text = "Nicu Dinita"
End With
Case 5
With ActiveDocument
.Range(26168, 26181).Text = "Asavei Sorin"
.Range(26062, 26088).Text = "BELRO INTERIOR DESIGN SRL"
.Range(11359, 11371).Text = "Asavei Sorin"
End With
Case 6
With ActiveDocument
.Range(26168, 26181).Text = "Ivan Maricel"
.Range(26062, 26088).Text = "Solomon & Aaron Construct"
.Range(11359, 11371).Text = "Ivan Maricel"
End With
End Select
Dim prijs As String
Dim besch As String
Dim eenh As String
Dim hoev As Integer
hoev = InputBox("Hoeveel artikels zijn er?")
Dim index As Integer
index = 1
While (index <= hoev)
besch = InputBox("Beschrijving van het artikel (engels)")
prijs = InputBox("prijs van het artikel")
eenh = InputBox("Eenheid van het artikel")
With ActiveDocument
.Range(5701, 5702).Text = "" + vbTab + spaties2(besch, prijs, eenh) + Chr(10) + vbTab
End With
index = index + 1
Wend
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Raes G. Schrijnwerken BVBA" + vbTab + vbTab + datum + Chr(10) + "Robert Klingstraat 5" + Chr(10) + "8940 Wervik"
.Footers(wdHeaderFooterPrimary).Range.Text = "Overeenkomst tot onderaanneming" + Chr(10) + "met betrekking tot:" + werf
.Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight
End With
If firma = "sorin" Then
ActiveDocument.Range(254, 255).ImportFragment "Z:\Raes Netwerk DATA\professioneel\004 Sjablonen\belro.docx", False
Else
If firma = "nicu" Then
With ActiveDocument
.Range(254, 255).ImportFragment "Z:\Raes Netwerk DATA\professioneel\004 Sjablonen\Nicu.docx", False
End With
Else
If firma = "marius" Then
ActiveDocument.Range(254, 255).ImportFragment "Z:\Raes Netwerk DATA\professioneel\004 Sjablonen\Marius.docx", False
End If
End If
End If
ActiveDocument.PrintOut
ActiveDocument.PrintOut
End Sub
Function spaties2(artikel As String, prijs As String, eenh As String) As String
'Another function to ensure length of String
Dim index As Integer
Dim eind As String
eind = "" + artikel + vbTab + vbTab + prijs + "€/" + eenh
While (Len(eind) < 100)
eind = eind + " "
Wend
spaties2 = eind
End Function
As you can see, the code is very basic. And although it works, it's no good to deliver.
The two defined Functions are simply formatting the String of the user because obviously the name of something is not always the same length.
I'd like to cut out the Range properties, because in my opinion, that's what makes the program so sensitive to changes.
Any and all suggestions are welcome.
note: For the moment, the contract can have three different 'target parties' so that's why the Select Case statement is there. It's going to be completely useless if it should grow but for now it works.
Here's one:
sName = Left(sName & Space(30), 30)
And I think it's better to use bookmarks as placeholders instead of using Range(start, end)
How to change programmatically the text of a Word Bookmark
I think that your code needs some Trim's, in order to avoid mistaken spaces before and after the names (when you use some inputboxes, I mean).
And you need to verify input dates, too.
For string concatenation, use the ampersand (&) better than the plus sign (+), in order to avoid mistaken sums.
Instead of Chr(10) I have some recommendations in order to make your code more readable:
Chr(13) = vbCr
Chr(10) = vbLf
Chr(13) & Chr(10) = vbCrLf
Verify that the files you are indicating exist.
Using Range with numerical values is definitely not reliable. Bookmarks, as Tim suggests or content controls if this is Word 2007 or later. Content Controls are Microsoft's recommendation, going forward, but I don't see any particular advantage one way or the other for your purpose.
Looking at all the InputBox calls I have to wonder whether displaying a VBA UserForm for the input might not be better? All the input fields in one place, rather than flashing multiple prompts. You can validate for correct input before the UserForm is removed from the screen, etc.