I am trying to write a Word macro to expand the Christoffel symbol automatically. The expansion is simple:$$
\Gamma_{\mu\nu}^\sigma=\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}+\partial_\nu g_{\rho\mu}-\partial_\rho g_{\mu\nu}\right)
$$One replaces the Christoffel symbol ##\Gamma_{\mu\nu}^\sigma## by a half times the inverse metric ##g^{\sigma\rho}## times the sum of slightly different index combinations of the partial derivative ##\partial_\mu## of the metric ##g_{\nu\rho}##. A new dummy index, ## \rho## in this case, is introduced (it is summed over) and the original indices ## \sigma,\mu,\nu## are placed carefully in the expansion. The Christoffel symbol occurs frequently in General Relativity and once I have done this a few times with different indices my eyes start to pop out, thus the motivation to write a macro to save said eyes.
The macro should be fairly straightforward. We want it to replace something like$$
A\Gamma_{\mu\nu}^\sigma X
$$by$$
A\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}+\partial_\nu g_{\rho\mu}-\partial_\rho g_{\mu\nu}\right)X
$$An equation is an OMath object which consists of OMathFunction objects. So each of ## A,\Gamma_{\mu\nu}^\sigma,X## in the first equation is an OMathFunction object. In theory it should be easy to replace the OMathFunction object ##\Gamma_{\mu\nu}^\sigma## by a bunch of new OMathFunction objects ##\frac{1}{2},g^{\sigma\rho},+\ etc##. Dream on!
When you want to add a new OMathFunction object, you need to call Add method of an OMathFunctions object. The OMathFunctions object is the list of OMathFunction objects in the equation. The second parameter of this Add method is the type of new OMathFunction to add. (This not well described in the documentation.) The list of types is here. So the fraction ##\frac{1}{2}## is an wdOMathFunctionFrac, the inverse metric which has superscripts ##g^{\sigma\rho}## is a wdOMathFunctionScrSup and ##+## is a wdOMathFunctionText. You can see all these in the debugger if you have a look at the OMathFunctions object. This Add method crashes with error 6219 if the type parameter is wdOMathFunctionText, so it is very difficult to get the ##+,-## signs into expansion. The only way I could discover was by using
Selection.TypeText ("+")
I could then insert ##g_{\mu\nu}+g^{\mu\nu}## at the selection point in an equation with this code:
Sub ExampleWriteExpression()
'insertion point should be in equation. Metric + inverse metric inserted
Dim Equation As OMath
Dim MathTerm As OMathFunction
If Selection.OMaths.Count <> 1 Then ExpanderFatalError ("Cursor must be in an equation.")
Set Equation = Selection.OMaths(1)
Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionScrSub)
MathTerm.ScrSub.E.Range = "g"
MathTerm.ScrSub.Sub.Range = ChrW(&H3BC) & ChrW(&H3BD)
Selection.TypeText ("+")
'Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionText) still gets error
Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionScrSup)
MathTerm.ScrSup.E.Range = "g"
MathTerm.ScrSup.Sup.Range = ChrW(&H3BC) & ChrW(&H3BD)
End Sub
There was quite a bit of difficulty in getting the selection in the right place and I kept getting things like$$
\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}\partial_\nu g_{\rho\mu}\partial_\rho g_{\mu\nu}\right)+-
$$It is necessary align the selection range with the equation range and this is not the simple matter of subtraction that you might expect! It now works properly and replaces multiple Christoffel symbols in an equation correctly. Click Read more below if you would like a look or copy. Covariant derivatives, Riemann tensors, using, metric and coordinates coming soon!
jpl on msofficeforums corrected me and showed me how to avoid using the Selection which is a bodge. I further refined his technique. It is now very beautiful.😅
'Macros to expand Christoffel symbols and more in MS equations in Office 365 (2019)
'By George Keeling and on my blog at www.general-relativity.net under Tools
'https://www.general-relativity.net/search/label/Tools
'Feel free to use, copy, modify and give away but not for commerce. Please credit me and the website.
'Bugs
'1) does not work with on non-italic indices
Option Explicit
Const gCapGamma = 915 'hex 393
Const gPartialDerivative = 8706 'hex 2202
Const gNabla = 8711
Const gMagic1 = -10187
Dim gIndexesUsed(1 To 51) As Integer 'Count of usage of each index alpha at 1, omega at 25, a at 26, z at 51
Dim gGreekUsed As Boolean
Sub ExpandSymbols()
'Expand all various symbols in an equation
Dim Equation As OMath
Dim MathTerm As OMathFunction, GammaTerm As OMathScrSubSup
Call ZapIndexesUsed
If Selection.OMaths.Count <> 1 Then
ExpanderFatalError ("Cursor must be in an equation.")
End If
Set Equation = Selection.OMaths(1)
Call FindIndexesUsed(Equation)
Call ExpandEquation(Equation)
End Sub
Sub ExpandEquation(ByVal Equation As OMath)
Dim MathTerm As OMathFunction, CovariantDerivativeTerm As OMathFunction
Dim InnerEquation As OMath
Dim iInnerEq As Integer
Set CovariantDerivativeTerm = Nothing
For Each MathTerm In Equation.Functions
If CovariantDerivativeTerm Is Nothing Then
If (MathTerm.Type = wdOMathFunctionScrSubSup) Then
If Len(MathTerm.Range.Text) >= 2 Then
If (AscW(Mid(MathTerm.Range.Text, 2, 1)) = gCapGamma) Then 'Have Christoffel symbol.
Call ExpandChristoffel(Equation.Functions, MathTerm)
End If
End If
ElseIf MathTerm.Type = wdOMathFunctionScrSub Then
If Len(MathTerm.Range.Text) >= 2 Then
If (AscW(Mid(MathTerm.Range.Text, 2, 1)) = gNabla) Then 'Nabla: Covariant derivative
Set CovariantDerivativeTerm = MathTerm
'and continue to the next term which is what we must operate on
End If
End If
ElseIf MathTerm.Type = wdOMathFunctionDelim Then 'delimiter - brackets, need to recurse
For iInnerEq = 1 To MathTerm.Delim.E.Count
Set InnerEquation = MathTerm.Delim.E.Item(iInnerEq)
Call ExpandEquation(InnerEquation)
Next
End If
Else
Call ExpandCovariantDerivative(Equation.Functions, CovariantDerivativeTerm, MathTerm)
Set CovariantDerivativeTerm = Nothing
End If
Next
End Sub
Sub ExpandChristoffel(Functions As OMathFunctions, MathTerm As OMathFunction)
'Expand Christoffel symbol
'Functions are the functions of the original equation, which we add to
'Mathterm is the Christoffel symbol term
Dim UpIndex As Integer, LeftIndex As Integer, RightIndex As Integer, DummyIndex As Integer
Dim NewMathTerm As OMathFunction
Dim BracketFunctions As OMathFunctions, BracketTerm As OMathFunction 'just like paramters of this function
Dim InsertionPoint As Range
UpIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sup.Range.Text, 2, 1))
LeftIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sub.Range.Text, 2, 1))
RightIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sub.Range.Text, 4, 1))
DummyIndex = GetNewDummyIndex()
MathTerm.Range.Text = "" 'removes Christoffel symbol
Set InsertionPoint = MathTerm.Range
'1/2
Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionFrac)
NewMathTerm.Frac.Num.Range.Text = "1"
NewMathTerm.Frac.Den.Range.Text = "2"
NewMathTerm.Frac.Type = wdOMathFracBar
'inverse metric
Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionScrSup)
NewMathTerm.ScrSup.E.Range = "g"
NewMathTerm.ScrSup.Sup.Range = ChrW(UpIndex) & ChrW(DummyIndex)
'brackets (defaults to round brackets)
Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionDelim)
Set BracketFunctions = NewMathTerm.Delim.E(1).Functions
Set BracketTerm = BracketFunctions(1)
InsertionPoint.Start = InsertionPoint.Start - 1 'get into the bracket
InsertionPoint.Collapse (wdCollapseStart)
'first + term
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex)
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = "g"
NewMathTerm.ScrSub.Sub.Range = ChrW(DummyIndex) & ChrW(RightIndex)
'second + term
Set InsertionPoint = BracketTerm.Range
Call InsertText(InsertionPoint, "+")
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
NewMathTerm.ScrSub.Sub.Range = ChrW(RightIndex)
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = "g"
NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex) & ChrW(DummyIndex)
'third - term
Call InsertText(InsertionPoint, "-")
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
NewMathTerm.ScrSub.Sub.Range = ChrW(DummyIndex)
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = "g"
NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex) & ChrW(RightIndex)
End Sub
Sub ExpandCovariantDerivative(Functions As OMathFunctions, CdTerm As OMathFunction, MathTerm As OMathFunction)
'Expand Covariant Derivative
'Functions are the functions of the original equation, which we add to
'CdTerm is the covariant derivative operator
'Mathterm is the term after the covariant derivative term, the operand, a tensor with up or down indices or both
'We do not (yet) do an operand in brackets or deal with metric compatibility
'first to all up indices, then all down indices
Dim UpIndexes(1 To 51) As Integer
Dim DownIndexes(1 To 51) As Integer
Dim UpIndexString As String, DownIndexString As String, Tensor As String, DummyIndex As Integer, CdIndex As Integer
Dim NewMathTerm As OMathFunction
If MathTerm.Type = wdOMathFunctionScrSub Then
DownIndexString = MathTerm.ScrSub.Sub.Range.Text
Tensor = ToUnicode(Mid(MathTerm.ScrSub.E.Range.Text, 2, 1))
ElseIf MathTerm.Type = wdOMathFunctionScrSup Then
UpIndexString = MathTerm.ScrSup.Sup.Range.Text
Tensor = ToUnicode(Mid(MathTerm.ScrSup.E.Range.Text, 2, 1))
ElseIf MathTerm.Type = wdOMathFunctionScrSubSup Then
DownIndexString = MathTerm.ScrSubSup.Sub.Range.Text
UpIndexString = MathTerm.ScrSubSup.Sup.Range.Text
Tensor = ToUnicode(Mid(MathTerm.ScrSubSup.E.Range.Text, 2, 1))
Else
Exit Sub 'cannot recognise operand ***************************************
End If
DummyIndex = GetNewDummyIndex()
CdIndex = ToUnicode(Mid(CdTerm.ScrSub.Sub.Range.Text, 2, 1))
CdTerm.ScrSub.E.Range.Text = ChrW(gPartialDerivative) 'change nabla to partial derivative
'Now add + term for each up index and - term for each down index
Selection.TypeText ("+" & Tensor)
End Sub
Sub ZapIndexesUsed()
'values preserved in gIndexesUsed from one call to another ...
Dim iIU As Integer
For iIU = 1 To UBound(gIndexesUsed)
gIndexesUsed(iIU) = 0
Next
gGreekUsed = False
End Sub
Sub FindIndexesUsed(ByVal Equation As OMath)
'Find all tensor indexes used in equation, so that we do not use them as dummy variables.
'only search for lower case italic roman and greek!
Dim MathTerm As OMathFunction
Dim InnerEquation As OMath
Dim iInnerEq As Integer
For Each MathTerm In Equation.Functions
If MathTerm.Type = wdOMathFunctionScrSubSup Then 'super and sub script
Call CheckIndexes(MathTerm.ScrSubSup.Sub.Range.Text)
Call CheckIndexes(MathTerm.ScrSubSup.Sup.Range.Text)
End If
If MathTerm.Type = wdOMathFunctionScrSup Then 'super script
Call CheckIndexes(MathTerm.ScrSup.Sup.Range.Text)
End If
If MathTerm.Type = wdOMathFunctionScrSub Then 'super script
Call CheckIndexes(MathTerm.ScrSub.Sub.Range.Text)
End If
If MathTerm.Type = wdOMathFunctionDelim Then 'delimiter - brackets, need to recurse
For iInnerEq = 1 To MathTerm.Delim.E.Count
Set InnerEquation = MathTerm.Delim.E.Item(iInnerEq)
Call FindIndexesUsed(InnerEquation)
Next
End If
Next
End Sub
Sub CheckIndexes(IndexText As String)
'Check all the indexes in a string which may contain spaces.
Dim iText As Integer, UniCode As Integer
For iText = 1 To Len(IndexText)
UniCode = 0
UniCode = ToUnicode(Mid(IndexText, iText, 1))
If UniCode = &H3D5 Then
UniCode = &H3C6 'alternate phi, same as phi
End If
'Now have correct Unicode char in UniCode which we will use to index into gIndexesUsed
If (UniCode > 0) Then
If (UniCode > 0) And (UniCode < &H7B) Then
'It's roman
UniCode = UniCode - &H60 + 25
Else
UniCode = UniCode - &H3B0
gGreekUsed = True
End If
gIndexesUsed(UniCode) = gIndexesUsed(UniCode) + 1
End If
Next
End Sub
Function ToUnicode(Char As String) As Integer
'convert one charachter string from equation into unicode. 0 if unknown.
'Charachter is lower case roman or greek italic.
'********** Need to add uppercase!!
'includes alternate theta, upsilon, phi
Dim CharCode As Integer
CharCode = AscW(Char)
If (CharCode >= -8452) And (CharCode <= -8423) Then
ToUnicode = 9397 + CharCode 'Unicode greek
ElseIf CharCode = 8462 Then
ToUnicode = &H68 'roman h is special. Planck at work!
ElseIf (CharCode >= -9138) And (CharCode <= -9113) Then
ToUnicode = 9235 + CharCode 'Unicode roman
Else
ToUnicode = 0
End If
End Function
Function GetNewDummyIndex() As Integer
'get new dummy index. greek if any greek in list, otherwise roman. Start with mu,nu,rho, sigma,tau,lambda, kappa
Dim iIU As Integer
If gGreekUsed Then
If gIndexesUsed(12) = 0 Then
gIndexesUsed(12) = 1
GetNewDummyIndex = &H3BC
Exit Function
End If
If gIndexesUsed(13) = 0 Then
gIndexesUsed(13) = 1
GetNewDummyIndex = &H3BD
Exit Function
End If
If gIndexesUsed(17) = 0 Then
gIndexesUsed(17) = 1
GetNewDummyIndex = &H3C1
Exit Function
End If
If gIndexesUsed(19) = 0 Then
gIndexesUsed(19) = 1
GetNewDummyIndex = &H3C3
Exit Function
End If
If gIndexesUsed(20) = 0 Then
gIndexesUsed(20) = 1
GetNewDummyIndex = &H3C4
Exit Function
End If
If gIndexesUsed(11) = 0 Then
gIndexesUsed(11) = 1
GetNewDummyIndex = &H3BB
Exit Function
End If
If gIndexesUsed(10) = 0 Then
gIndexesUsed(10) = 1
GetNewDummyIndex = &H3BA
Exit Function
End If
'No obvious spare ones found. Start at alpha and at z (oops, in worst case could be roman)
For iIU = 1 To UBound(gIndexesUsed)
If gIndexesUsed(iIU) = 0 Then
gIndexesUsed(iIU) = 1
If iIU <= 25 Then
GetNewDummyIndex = iIU + &H3B0 'greek
Else
GetNewDummyIndex = iIU + &H60 'bad luck roman
End If
Exit Function
End If
Next
Else
'roman just do a to z then alpha to omega
For iIU = 26 To 51
If gIndexesUsed(iIU) = 0 Then
gIndexesUsed(iIU) = 1
GetNewDummyIndex = iIU + &H60 - 25
Exit Function
End If
Next
For iIU = 1 To 25
If gIndexesUsed(iIU) = 0 Then
gIndexesUsed(iIU) = 1
GetNewDummyIndex = iIU + &H3B0
Exit Function
End If
Next
End If
'very bad luck, no indices left
GetNewDummyIndex = &H2605 'black star
End Function
Function InsertFunction(Functions As OMathFunctions, InsertionPoint As Range, FuncType As WdOMathFunctionType) As OMathFunction
'Add a function in Functions at InsertionPoint and move InsertionPoint to after the function, ready for next
Dim NewFunction As OMathFunction
Set NewFunction = Functions.Add(InsertionPoint, FuncType)
Set InsertionPoint = NewFunction.Range
InsertionPoint.Collapse (wdCollapseEnd)
Set InsertFunction = NewFunction
End Function
Sub InsertText(InsertionPoint As Range, MyText As String)
'Inserts MyText at InsertionPoint and returns moves InsertionPoint to after that text
'so this is very similar to
'Equation.Functions.Add(InsertionPoint, wdOMathFunctionNormalText) .... which does not work!!
'many thankss to jpl for this. https://www.msofficeforums.com/word-vba/31587-vba-omath-object.html
InsertionPoint.Text = MyText
InsertionPoint.Collapse (wdCollapseEnd)
End Sub
Sub ExpanderFatalError(Message As String)
Call MsgBox(Message, vbOKOnly, "Expander says")
End
End Sub
'******************************** test functions below here
Sub junk()
End Sub
Sub ExampleWriteSymbols()
'Insert capital gamma, partial derivative, nabla
Call Selection.InsertSymbol(gCapGamma, , True)
Call Selection.InsertSymbol(gPartialDerivative, , True)
Call Selection.InsertSymbol(gNabla, , True)
End Sub
Sub ExampleWriteAlphabet()
'insertion point should be in equation. alphabet written one charachter before end.
Dim LetterCode As Integer, Letter0 As Integer
Dim Equation As OMath
Dim MathTerm As OMathFunction, GammaTerm As OMathScrSubSup
Dim MyRange As Range
Letter0 = &H61 ' Start letter = 391 ALPHA, 3B1 alpha, 41 A, 61 a
If Selection.OMaths.Count <> 1 Then
ExpanderFatalError ("Cursor must be in an equation.")
End If
Set Equation = Selection.OMaths(1)
Set MyRange = Equation.Range
MyRange.Collapse (wdCollapseEnd)
Call MyRange.MoveEnd(wdCharacter, -1)
MyRange.Text = ""
For LetterCode = Letter0 To Letter0 + 20
MyRange.Text = MyRange.Text & ChrW(LetterCode)
Next
'Set MathTerm = Equation.Functions.Add(MyRange, wdOMathFunctionNormalText)
End Sub
Sub ExampleWriteExpression()
'insertion point should be in equation. Metric + inverse metric inserted
Dim Equation As OMath
Dim MathTerm As OMathFunction
Dim InsertionPoint As Range
If Selection.OMaths.Count <> 1 Then ExpanderFatalError ("Cursor must be in an equation.")
Set Equation = Selection.OMaths(1)
Set InsertionPoint = Selection.Range
Set MathTerm = InsertFunction(Equation.Functions, InsertionPoint, wdOMathFunctionScrSub)
MathTerm.ScrSub.E.Range = "g"
MathTerm.ScrSub.Sub.Range = ChrW(&H3BC) & ChrW(&H3BD)
Call InsertText(InsertionPoint, "+")
Set MathTerm = InsertFunction(Equation.Functions, InsertionPoint, wdOMathFunctionScrSup)
MathTerm.ScrSup.E.Range = "g"
MathTerm.ScrSup.Sup.Range = ChrW(&H3BC) & ChrW(&H3BD)
End Sub
Sub ExampleReadSymbols()
Dim Equation As OMath
Dim MathTerm As OMathFunction
Dim Symbol(1 To 6) As Integer
If Selection.OMaths.Count <> 1 Then
ExpanderFatalError ("Cursor must be in equation.")
End If
Set Equation = Selection.OMaths(1)
For Each MathTerm In Equation.Functions
Symbol(1) = AscW(Mid(MathTerm.Range.Text, 1, 1))
Symbol(2) = AscW(Mid(MathTerm.Range.Text, 2, 1))
Symbol(3) = AscW(Mid(MathTerm.Range.Text, 3, 1))
Symbol(4) = AscW(Mid(MathTerm.Range.Text, 4, 1))
Symbol(5) = AscW(Mid(MathTerm.Range.Text, 5, 1))
Symbol(6) = AscW(Mid(MathTerm.Range.Text, 6, 1))
Next
End Sub 'break here to check results
\Gamma_{\mu\nu}^\sigma=\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}+\partial_\nu g_{\rho\mu}-\partial_\rho g_{\mu\nu}\right)
$$One replaces the Christoffel symbol ##\Gamma_{\mu\nu}^\sigma## by a half times the inverse metric ##g^{\sigma\rho}## times the sum of slightly different index combinations of the partial derivative ##\partial_\mu## of the metric ##g_{\nu\rho}##. A new dummy index, ## \rho## in this case, is introduced (it is summed over) and the original indices ## \sigma,\mu,\nu## are placed carefully in the expansion. The Christoffel symbol occurs frequently in General Relativity and once I have done this a few times with different indices my eyes start to pop out, thus the motivation to write a macro to save said eyes.
The macro should be fairly straightforward. We want it to replace something like$$
A\Gamma_{\mu\nu}^\sigma X
$$by$$
A\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}+\partial_\nu g_{\rho\mu}-\partial_\rho g_{\mu\nu}\right)X
$$An equation is an OMath object which consists of OMathFunction objects. So each of ## A,\Gamma_{\mu\nu}^\sigma,X## in the first equation is an OMathFunction object. In theory it should be easy to replace the OMathFunction object ##\Gamma_{\mu\nu}^\sigma## by a bunch of new OMathFunction objects ##\frac{1}{2},g^{\sigma\rho},+\ etc##. Dream on!
When you want to add a new OMathFunction object, you need to call Add method of an OMathFunctions object. The OMathFunctions object is the list of OMathFunction objects in the equation. The second parameter of this Add method is the type of new OMathFunction to add. (This not well described in the documentation.) The list of types is here. So the fraction ##\frac{1}{2}## is an wdOMathFunctionFrac, the inverse metric which has superscripts ##g^{\sigma\rho}## is a wdOMathFunctionScrSup and ##+## is a wdOMathFunctionText. You can see all these in the debugger if you have a look at the OMathFunctions object. This Add method crashes with error 6219 if the type parameter is wdOMathFunctionText, so it is very difficult to get the ##+,-## signs into expansion. The only way I could discover was by using
Selection.TypeText ("+")
I could then insert ##g_{\mu\nu}+g^{\mu\nu}## at the selection point in an equation with this code:
Sub ExampleWriteExpression()
'insertion point should be in equation. Metric + inverse metric inserted
Dim Equation As OMath
Dim MathTerm As OMathFunction
If Selection.OMaths.Count <> 1 Then ExpanderFatalError ("Cursor must be in an equation.")
Set Equation = Selection.OMaths(1)
Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionScrSub)
MathTerm.ScrSub.E.Range = "g"
MathTerm.ScrSub.Sub.Range = ChrW(&H3BC) & ChrW(&H3BD)
Selection.TypeText ("+")
'Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionText) still gets error
Set MathTerm = Equation.Functions.Add(Selection.Range, wdOMathFunctionScrSup)
MathTerm.ScrSup.E.Range = "g"
MathTerm.ScrSup.Sup.Range = ChrW(&H3BC) & ChrW(&H3BD)
End Sub
There was quite a bit of difficulty in getting the selection in the right place and I kept getting things like$$
\frac{1}{2}g^{\sigma\rho}\left(\partial_\mu g_{\nu\rho}\partial_\nu g_{\rho\mu}\partial_\rho g_{\mu\nu}\right)+-
$$It is necessary align the selection range with the equation range and this is not the simple matter of subtraction that you might expect! It now works properly and replaces multiple Christoffel symbols in an equation correctly. Click Read more below if you would like a look or copy. Covariant derivatives, Riemann tensors, using, metric and coordinates coming soon!
jpl on msofficeforums corrected me and showed me how to avoid using the Selection which is a bodge. I further refined his technique. It is now very beautiful.😅
'Macros to expand Christoffel symbols and more in MS equations in Office 365 (2019)
'By George Keeling and on my blog at www.general-relativity.net under Tools
'https://www.general-relativity.net/search/label/Tools
'Feel free to use, copy, modify and give away but not for commerce. Please credit me and the website.
'Bugs
'1) does not work with on non-italic indices
Option Explicit
Const gCapGamma = 915 'hex 393
Const gPartialDerivative = 8706 'hex 2202
Const gNabla = 8711
Const gMagic1 = -10187
Dim gIndexesUsed(1 To 51) As Integer 'Count of usage of each index alpha at 1, omega at 25, a at 26, z at 51
Dim gGreekUsed As Boolean
Sub ExpandSymbols()
'Expand all various symbols in an equation
Dim Equation As OMath
Dim MathTerm As OMathFunction, GammaTerm As OMathScrSubSup
Call ZapIndexesUsed
If Selection.OMaths.Count <> 1 Then
ExpanderFatalError ("Cursor must be in an equation.")
End If
Set Equation = Selection.OMaths(1)
Call FindIndexesUsed(Equation)
Call ExpandEquation(Equation)
End Sub
Sub ExpandEquation(ByVal Equation As OMath)
Dim MathTerm As OMathFunction, CovariantDerivativeTerm As OMathFunction
Dim InnerEquation As OMath
Dim iInnerEq As Integer
Set CovariantDerivativeTerm = Nothing
For Each MathTerm In Equation.Functions
If CovariantDerivativeTerm Is Nothing Then
If (MathTerm.Type = wdOMathFunctionScrSubSup) Then
If Len(MathTerm.Range.Text) >= 2 Then
If (AscW(Mid(MathTerm.Range.Text, 2, 1)) = gCapGamma) Then 'Have Christoffel symbol.
Call ExpandChristoffel(Equation.Functions, MathTerm)
End If
End If
ElseIf MathTerm.Type = wdOMathFunctionScrSub Then
If Len(MathTerm.Range.Text) >= 2 Then
If (AscW(Mid(MathTerm.Range.Text, 2, 1)) = gNabla) Then 'Nabla: Covariant derivative
Set CovariantDerivativeTerm = MathTerm
'and continue to the next term which is what we must operate on
End If
End If
ElseIf MathTerm.Type = wdOMathFunctionDelim Then 'delimiter - brackets, need to recurse
For iInnerEq = 1 To MathTerm.Delim.E.Count
Set InnerEquation = MathTerm.Delim.E.Item(iInnerEq)
Call ExpandEquation(InnerEquation)
Next
End If
Else
Call ExpandCovariantDerivative(Equation.Functions, CovariantDerivativeTerm, MathTerm)
Set CovariantDerivativeTerm = Nothing
End If
Next
End Sub
Sub ExpandChristoffel(Functions As OMathFunctions, MathTerm As OMathFunction)
'Expand Christoffel symbol
'Functions are the functions of the original equation, which we add to
'Mathterm is the Christoffel symbol term
Dim UpIndex As Integer, LeftIndex As Integer, RightIndex As Integer, DummyIndex As Integer
Dim NewMathTerm As OMathFunction
Dim BracketFunctions As OMathFunctions, BracketTerm As OMathFunction 'just like paramters of this function
Dim InsertionPoint As Range
UpIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sup.Range.Text, 2, 1))
LeftIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sub.Range.Text, 2, 1))
RightIndex = ToUnicode(Mid(MathTerm.ScrSubSup.Sub.Range.Text, 4, 1))
DummyIndex = GetNewDummyIndex()
MathTerm.Range.Text = "" 'removes Christoffel symbol
Set InsertionPoint = MathTerm.Range
'1/2
Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionFrac)
NewMathTerm.Frac.Num.Range.Text = "1"
NewMathTerm.Frac.Den.Range.Text = "2"
NewMathTerm.Frac.Type = wdOMathFracBar
'inverse metric
Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionScrSup)
NewMathTerm.ScrSup.E.Range = "g"
NewMathTerm.ScrSup.Sup.Range = ChrW(UpIndex) & ChrW(DummyIndex)
'brackets (defaults to round brackets)
Set NewMathTerm = InsertFunction(Functions, InsertionPoint, wdOMathFunctionDelim)
Set BracketFunctions = NewMathTerm.Delim.E(1).Functions
Set BracketTerm = BracketFunctions(1)
InsertionPoint.Start = InsertionPoint.Start - 1 'get into the bracket
InsertionPoint.Collapse (wdCollapseStart)
'first + term
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex)
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = "g"
NewMathTerm.ScrSub.Sub.Range = ChrW(DummyIndex) & ChrW(RightIndex)
'second + term
Set InsertionPoint = BracketTerm.Range
Call InsertText(InsertionPoint, "+")
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
NewMathTerm.ScrSub.Sub.Range = ChrW(RightIndex)
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = "g"
NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex) & ChrW(DummyIndex)
'third - term
Call InsertText(InsertionPoint, "-")
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = ChrW(gPartialDerivative)
NewMathTerm.ScrSub.Sub.Range = ChrW(DummyIndex)
Set NewMathTerm = InsertFunction(BracketFunctions, InsertionPoint, wdOMathFunctionScrSub)
NewMathTerm.ScrSub.E.Range = "g"
NewMathTerm.ScrSub.Sub.Range = ChrW(LeftIndex) & ChrW(RightIndex)
End Sub
Sub ExpandCovariantDerivative(Functions As OMathFunctions, CdTerm As OMathFunction, MathTerm As OMathFunction)
'Expand Covariant Derivative
'Functions are the functions of the original equation, which we add to
'CdTerm is the covariant derivative operator
'Mathterm is the term after the covariant derivative term, the operand, a tensor with up or down indices or both
'We do not (yet) do an operand in brackets or deal with metric compatibility
'first to all up indices, then all down indices
Dim UpIndexes(1 To 51) As Integer
Dim DownIndexes(1 To 51) As Integer
Dim UpIndexString As String, DownIndexString As String, Tensor As String, DummyIndex As Integer, CdIndex As Integer
Dim NewMathTerm As OMathFunction
If MathTerm.Type = wdOMathFunctionScrSub Then
DownIndexString = MathTerm.ScrSub.Sub.Range.Text
Tensor = ToUnicode(Mid(MathTerm.ScrSub.E.Range.Text, 2, 1))
ElseIf MathTerm.Type = wdOMathFunctionScrSup Then
UpIndexString = MathTerm.ScrSup.Sup.Range.Text
Tensor = ToUnicode(Mid(MathTerm.ScrSup.E.Range.Text, 2, 1))
ElseIf MathTerm.Type = wdOMathFunctionScrSubSup Then
DownIndexString = MathTerm.ScrSubSup.Sub.Range.Text
UpIndexString = MathTerm.ScrSubSup.Sup.Range.Text
Tensor = ToUnicode(Mid(MathTerm.ScrSubSup.E.Range.Text, 2, 1))
Else
Exit Sub 'cannot recognise operand ***************************************
End If
DummyIndex = GetNewDummyIndex()
CdIndex = ToUnicode(Mid(CdTerm.ScrSub.Sub.Range.Text, 2, 1))
CdTerm.ScrSub.E.Range.Text = ChrW(gPartialDerivative) 'change nabla to partial derivative
'Now add + term for each up index and - term for each down index
Selection.TypeText ("+" & Tensor)
End Sub
Sub ZapIndexesUsed()
'values preserved in gIndexesUsed from one call to another ...
Dim iIU As Integer
For iIU = 1 To UBound(gIndexesUsed)
gIndexesUsed(iIU) = 0
Next
gGreekUsed = False
End Sub
Sub FindIndexesUsed(ByVal Equation As OMath)
'Find all tensor indexes used in equation, so that we do not use them as dummy variables.
'only search for lower case italic roman and greek!
Dim MathTerm As OMathFunction
Dim InnerEquation As OMath
Dim iInnerEq As Integer
For Each MathTerm In Equation.Functions
If MathTerm.Type = wdOMathFunctionScrSubSup Then 'super and sub script
Call CheckIndexes(MathTerm.ScrSubSup.Sub.Range.Text)
Call CheckIndexes(MathTerm.ScrSubSup.Sup.Range.Text)
End If
If MathTerm.Type = wdOMathFunctionScrSup Then 'super script
Call CheckIndexes(MathTerm.ScrSup.Sup.Range.Text)
End If
If MathTerm.Type = wdOMathFunctionScrSub Then 'super script
Call CheckIndexes(MathTerm.ScrSub.Sub.Range.Text)
End If
If MathTerm.Type = wdOMathFunctionDelim Then 'delimiter - brackets, need to recurse
For iInnerEq = 1 To MathTerm.Delim.E.Count
Set InnerEquation = MathTerm.Delim.E.Item(iInnerEq)
Call FindIndexesUsed(InnerEquation)
Next
End If
Next
End Sub
Sub CheckIndexes(IndexText As String)
'Check all the indexes in a string which may contain spaces.
Dim iText As Integer, UniCode As Integer
For iText = 1 To Len(IndexText)
UniCode = 0
UniCode = ToUnicode(Mid(IndexText, iText, 1))
If UniCode = &H3D5 Then
UniCode = &H3C6 'alternate phi, same as phi
End If
'Now have correct Unicode char in UniCode which we will use to index into gIndexesUsed
If (UniCode > 0) Then
If (UniCode > 0) And (UniCode < &H7B) Then
'It's roman
UniCode = UniCode - &H60 + 25
Else
UniCode = UniCode - &H3B0
gGreekUsed = True
End If
gIndexesUsed(UniCode) = gIndexesUsed(UniCode) + 1
End If
Next
End Sub
Function ToUnicode(Char As String) As Integer
'convert one charachter string from equation into unicode. 0 if unknown.
'Charachter is lower case roman or greek italic.
'********** Need to add uppercase!!
'includes alternate theta, upsilon, phi
Dim CharCode As Integer
CharCode = AscW(Char)
If (CharCode >= -8452) And (CharCode <= -8423) Then
ToUnicode = 9397 + CharCode 'Unicode greek
ElseIf CharCode = 8462 Then
ToUnicode = &H68 'roman h is special. Planck at work!
ElseIf (CharCode >= -9138) And (CharCode <= -9113) Then
ToUnicode = 9235 + CharCode 'Unicode roman
Else
ToUnicode = 0
End If
End Function
Function GetNewDummyIndex() As Integer
'get new dummy index. greek if any greek in list, otherwise roman. Start with mu,nu,rho, sigma,tau,lambda, kappa
Dim iIU As Integer
If gGreekUsed Then
If gIndexesUsed(12) = 0 Then
gIndexesUsed(12) = 1
GetNewDummyIndex = &H3BC
Exit Function
End If
If gIndexesUsed(13) = 0 Then
gIndexesUsed(13) = 1
GetNewDummyIndex = &H3BD
Exit Function
End If
If gIndexesUsed(17) = 0 Then
gIndexesUsed(17) = 1
GetNewDummyIndex = &H3C1
Exit Function
End If
If gIndexesUsed(19) = 0 Then
gIndexesUsed(19) = 1
GetNewDummyIndex = &H3C3
Exit Function
End If
If gIndexesUsed(20) = 0 Then
gIndexesUsed(20) = 1
GetNewDummyIndex = &H3C4
Exit Function
End If
If gIndexesUsed(11) = 0 Then
gIndexesUsed(11) = 1
GetNewDummyIndex = &H3BB
Exit Function
End If
If gIndexesUsed(10) = 0 Then
gIndexesUsed(10) = 1
GetNewDummyIndex = &H3BA
Exit Function
End If
'No obvious spare ones found. Start at alpha and at z (oops, in worst case could be roman)
For iIU = 1 To UBound(gIndexesUsed)
If gIndexesUsed(iIU) = 0 Then
gIndexesUsed(iIU) = 1
If iIU <= 25 Then
GetNewDummyIndex = iIU + &H3B0 'greek
Else
GetNewDummyIndex = iIU + &H60 'bad luck roman
End If
Exit Function
End If
Next
Else
'roman just do a to z then alpha to omega
For iIU = 26 To 51
If gIndexesUsed(iIU) = 0 Then
gIndexesUsed(iIU) = 1
GetNewDummyIndex = iIU + &H60 - 25
Exit Function
End If
Next
For iIU = 1 To 25
If gIndexesUsed(iIU) = 0 Then
gIndexesUsed(iIU) = 1
GetNewDummyIndex = iIU + &H3B0
Exit Function
End If
Next
End If
'very bad luck, no indices left
GetNewDummyIndex = &H2605 'black star
End Function
Function InsertFunction(Functions As OMathFunctions, InsertionPoint As Range, FuncType As WdOMathFunctionType) As OMathFunction
'Add a function in Functions at InsertionPoint and move InsertionPoint to after the function, ready for next
Dim NewFunction As OMathFunction
Set NewFunction = Functions.Add(InsertionPoint, FuncType)
Set InsertionPoint = NewFunction.Range
InsertionPoint.Collapse (wdCollapseEnd)
Set InsertFunction = NewFunction
End Function
Sub InsertText(InsertionPoint As Range, MyText As String)
'Inserts MyText at InsertionPoint and returns moves InsertionPoint to after that text
'so this is very similar to
'Equation.Functions.Add(InsertionPoint, wdOMathFunctionNormalText) .... which does not work!!
'many thankss to jpl for this. https://www.msofficeforums.com/word-vba/31587-vba-omath-object.html
InsertionPoint.Text = MyText
InsertionPoint.Collapse (wdCollapseEnd)
End Sub
Sub ExpanderFatalError(Message As String)
Call MsgBox(Message, vbOKOnly, "Expander says")
End
End Sub
'******************************** test functions below here
Sub junk()
End Sub
Sub ExampleWriteSymbols()
'Insert capital gamma, partial derivative, nabla
Call Selection.InsertSymbol(gCapGamma, , True)
Call Selection.InsertSymbol(gPartialDerivative, , True)
Call Selection.InsertSymbol(gNabla, , True)
End Sub
Sub ExampleWriteAlphabet()
'insertion point should be in equation. alphabet written one charachter before end.
Dim LetterCode As Integer, Letter0 As Integer
Dim Equation As OMath
Dim MathTerm As OMathFunction, GammaTerm As OMathScrSubSup
Dim MyRange As Range
Letter0 = &H61 ' Start letter = 391 ALPHA, 3B1 alpha, 41 A, 61 a
If Selection.OMaths.Count <> 1 Then
ExpanderFatalError ("Cursor must be in an equation.")
End If
Set Equation = Selection.OMaths(1)
Set MyRange = Equation.Range
MyRange.Collapse (wdCollapseEnd)
Call MyRange.MoveEnd(wdCharacter, -1)
MyRange.Text = ""
For LetterCode = Letter0 To Letter0 + 20
MyRange.Text = MyRange.Text & ChrW(LetterCode)
Next
'Set MathTerm = Equation.Functions.Add(MyRange, wdOMathFunctionNormalText)
End Sub
Sub ExampleWriteExpression()
'insertion point should be in equation. Metric + inverse metric inserted
Dim Equation As OMath
Dim MathTerm As OMathFunction
Dim InsertionPoint As Range
If Selection.OMaths.Count <> 1 Then ExpanderFatalError ("Cursor must be in an equation.")
Set Equation = Selection.OMaths(1)
Set InsertionPoint = Selection.Range
Set MathTerm = InsertFunction(Equation.Functions, InsertionPoint, wdOMathFunctionScrSub)
MathTerm.ScrSub.E.Range = "g"
MathTerm.ScrSub.Sub.Range = ChrW(&H3BC) & ChrW(&H3BD)
Call InsertText(InsertionPoint, "+")
Set MathTerm = InsertFunction(Equation.Functions, InsertionPoint, wdOMathFunctionScrSup)
MathTerm.ScrSup.E.Range = "g"
MathTerm.ScrSup.Sup.Range = ChrW(&H3BC) & ChrW(&H3BD)
End Sub
Sub ExampleReadSymbols()
Dim Equation As OMath
Dim MathTerm As OMathFunction
Dim Symbol(1 To 6) As Integer
If Selection.OMaths.Count <> 1 Then
ExpanderFatalError ("Cursor must be in equation.")
End If
Set Equation = Selection.OMaths(1)
For Each MathTerm In Equation.Functions
Symbol(1) = AscW(Mid(MathTerm.Range.Text, 1, 1))
Symbol(2) = AscW(Mid(MathTerm.Range.Text, 2, 1))
Symbol(3) = AscW(Mid(MathTerm.Range.Text, 3, 1))
Symbol(4) = AscW(Mid(MathTerm.Range.Text, 4, 1))
Symbol(5) = AscW(Mid(MathTerm.Range.Text, 5, 1))
Symbol(6) = AscW(Mid(MathTerm.Range.Text, 6, 1))
Next
End Sub 'break here to check results
No comments:
Post a Comment