# I'm looking for a tetrahedral (triangle pyramid) inscribed sphere sympy. I tried it on the vba solver.

Asked 5 months ago, Updated 5 months ago, 20 views

②I tried running it on the vba solver. Please tell me how to shorten the vba code.Only one example has been performed.
➂Failed to write "Range("A7").Formula" multiple lines of code below.

Original Post
(0,0,0), (1,0,0), (0,1,0), (0,0,2)
2021 Kyushu University/Science Mathematics Question 1(1)
https://www.densu.jp/kyusyu/21kyusyuspass.pdf

Reference
"CASIO>Flat expression containing three points, volume of tetrahedron formed at four points"
https://keisan.casio.jp/exec/system/1202458197
https://keisan.casio.jp/exec/system/1202458218
"Wolfram | Alpha"
https://ja.wolframalpha.com/input/?i=%280%2C0%2C0%2C%281%2C0%2C0%2C0%2C0%2C%2C1%2C0%2C0%2C0%2C0%2C2%29
https://ja.wolframalpha.com/input/?i=%E4%B8%89%E8%A7%92%E9%8C%90%EF%BC%880%2C0%2C0%2C0%2C0%2C0%2C0%2C0%2C0%2C%2C1%2C0%2C0%2C%2C0%2C0%2C2%29

``````Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Function mySimentaiTaiseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiTaiseki=_
((x4-x1)*Abs(y2-y1)*(z3-z1)-(z3-z1)*(y3-y1)_
+ (y4-y1)*Abs(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)_
+ (z4-z1)*Abs(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)/6#
End Function
Function myDis(x1,y1,z1,x2,y2,z2)
myDis=Sqr(x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
End Function
Function myHeron (x1, y1, z1, x2, y2, z2, x3, y3, z3)
s=(myDis(x1,y1,z1,x2,y2,z2) + myDis(x2,y2,z2,x3,y3,z3) + myDis(x3,y3,z3,x1,y1,z1)/2#
myHeron=Sqr(s*(s-myDis(x1,y1,z1,x2,y2,z2))*(s-myDis(x2,y2,z2,x3,y3,z3))*(s-myDis(x3,y3,z3,x1,y1,z1))))
End Function
Function mySimentaiMenseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiMenseki=_
myHeron(x1,y1,z1,x2,z2,x3,y3,z3)_
+ myHeron(x2,y2,z2,x3,z3,x4,y4,z4)_
+ myHeron(x3,y3,z3,x4,z4,x1,y1,z1)_
+ myHeron (x4, y4, z4, x1, y1, z1, x2, y2, z2)
End Function
Subaaa_Sankakusui()
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
ActiveSheet.Cells.Clear
'
MsgBox "Calculate the inscribed sphere of a tetrahedron (triangle pyramid) with a solver."
'
Range ("A1") = Ax
Range ("B1") = Ay
Range ("C1") = Az
Range ("A2") = Bx
Range ("B2") = By
Range ("C2") = Bz
Range ("A3") = Cx
Range ("B3") = Cy
Range ("C3") = Cz
Range ("A4") = Dx
Range ("B4") = Dy
Range ("C4") = Dz
Range("A5") = mySimentaiTaiseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("B5") = mySimentaiMenseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("C5").Formula="=A5*3.0/B5"
'
vD = myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen (Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen (Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
vC = myHeimen (Dx, Dy, Dz, Ax, Ay, Az, Bx, By, Bz)
'       "
Range("E1") = vD(0)
Range("F1") = vD(1)
Range("G1") = vD(2)
Range("H1") = vD(3)
Range("E2") = vA(0)
Range("F2") = vA(1)
Range("G2") = vA(2)
Range("H2") = vA(3)
Range("E3") = vB(0)
Range("F3") = vB(1)
Range("G3") = vB(2)
Range("H3") = vB(3)
Range("E4") = vC(0)
Range("F4") = vC(1)
Range ("G4") = vC(2)
Range("H4") = vC(3)
Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - C5) ^ 2   + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - C5) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - C5) ^ 2  + (Abs(E4 * A6 + F4 * B6 + G4 * C6 + H4) / Sqrt(E4 ^ 2 + F4 ^ 2 + G4 ^ 2) - C5) ^ 2"
Dimws As Worksheet:Sets=ActiveSheet
SolverReset
SolverOksetCell: =ws.Range("A7"),_
MaxMinVal: =3,_
ByChange: =ws.Range("A6:C6"), _
EngineDesc: = "GRG Nonlinear"
SolverSolve UserFinish: = True
End Sub
'Results
'Central coordinates 0.2499997050.2499998220.249999802 of the sphere inscribed in the tetrahedron
``````

vba sympy

2022-09-30 11:10

vba solver (of 2)
The radius of the sphere has also been added to the cell (variable cell) to be changed.As a result, surface area and volume calculations are no longer required.

``````Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Subaaa_Sankakusui()
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
ActiveSheet.Cells.Clear
'
MsgBox"'Calculate the inscribed sphere of the tetrahedron (triangle pyramid) with a solver."
'
Range ("A1") = Ax
Range ("B1") = Ay
Range ("C1") = Az
Range ("A2") = Bx
Range ("B2") = By
Range ("C2") = Bz
Range ("A3") = Cx
Range ("B3") = Cy
Range ("C3") = Cz
Range ("A4") = Dx
Range ("B4") = Dy
Range ("C4") = Dz
'
vD = myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen (Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen (Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
vC = myHeimen (Dx, Dy, Dz, Ax, Ay, Az, Bx, By, Bz)
'       "
Range("E1") = vD(0)
Range("F1") = vD(1)
Range("G1") = vD(2)
Range("H1") = vD(3)
Range("E2") = vA(0)
Range("F2") = vA(1)
Range("G2") = vA(2)
Range("H2") = vA(3)
Range("E3") = vB(0)
Range("F3") = vB(1)
Range("G3") = vB(2)
Range("H3") = vB(3)
Range("E4") = vC(0)
Range("F4") = vC(1)
Range ("G4") = vC(2)
Range("H4") = vC(3)
Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - D6) ^ 2   + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - D6) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - D6) ^ 2  + (Abs(E4 * A6 + F4 * B6 + G4 * C6 + H4) / Sqrt(E4 ^ 2 + F4 ^ 2 + G4 ^ 2) - D6) ^ 2"
Dimws As Worksheet:Sets=ActiveSheet
SolverReset
SolverOksetCell: =ws.Range("A7"),_
MaxMinVal: =3,_
ByChange: =ws.Range("A6:D6"), _
EngineDesc: = "GRG Nonlinear"
SolverSolve UserFinish: = True
End Sub
'Results
The central coordinates of the sphere inscribed in the tetrahedron 0.2500002010.24999420.249998773
``````

2022-09-30 11:10

vba solver (of 3)
For (1) the fourth vertical line calculation was not required because the radius of the sphere was calculated.

``````Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Function mySimentaiTaiseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiTaiseki=_
((x4-x1)*Abs(y2-y1)*(z3-z1)-(z3-z1)*(y3-y1)_
+ (y4-y1)*Abs(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)_
+ (z4-z1)*Abs(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)/6#
End Function
Function myDis(x1,y1,z1,x2,y2,z2)
myDis=Sqr(x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
End Function
Function myHeron (x1, y1, z1, x2, y2, z2, x3, y3, z3)
s=(myDis(x1,y1,z1,x2,y2,z2) + myDis(x2,y2,z2,x3,y3,z3) + myDis(x3,y3,z3,x1,y1,z1)/2#
myHeron=Sqr(s*(s-myDis(x1,y1,z1,x2,y2,z2))*(s-myDis(x2,y2,z2,x3,y3,z3))*(s-myDis(x3,y3,z3,x1,y1,z1))))
End Function
Function mySimentaiMenseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiMenseki=_
myHeron(x1,y1,z1,x2,z2,x3,y3,z3)_
+ myHeron(x2,y2,z2,x3,z3,x4,y4,z4)_
+ myHeron(x3,y3,z3,x4,z4,x1,y1,z1)_
+ myHeron (x4, y4, z4, x1, y1, z1, x2, y2, z2)
End Function
Subaaa_Sankakusui()
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
ActiveSheet.Cells.Clear
'
MsgBox "Calculate the inscribed sphere of a tetrahedron (triangle pyramid) with a solver."
'
Range ("A1") = Ax
Range ("B1") = Ay
Range ("C1") = Az
Range ("A2") = Bx
Range ("B2") = By
Range ("C2") = Bz
Range ("A3") = Cx
Range ("B3") = Cy
Range ("C3") = Cz
Range ("A4") = Dx
Range ("B4") = Dy
Range ("C4") = Dz
Range("A5") = mySimentaiTaiseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("B5") = mySimentaiMenseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
Range("C5").Formula="=A5*3.0/B5"
'
vD = myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen (Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen (Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
'       "
Range("E1") = vD(0)
Range("F1") = vD(1)
Range("G1") = vD(2)
Range("H1") = vD(3)
Range("E2") = vA(0)
Range("F2") = vA(1)
Range("G2") = vA(2)
Range("H2") = vA(3)
Range("E3") = vB(0)
Range("F3") = vB(1)
Range("G3") = vB(2)
Range("H3") = vB(3)
Range("A7").Formula = "= (Abs(E1 * A6 + F1 * B6 + G1 * C6 + H1) / Sqrt(E1 ^ 2 + F1 ^ 2 + G1 ^ 2) - C5) ^ 2   + (Abs(E2 * A6 + F2 * B6 + G2 * C6 + H2) / Sqrt(E2 ^ 2 + F2 ^ 2 + G2 ^ 2) - C5) ^ 2 + (Abs(E3 * A6 + F3 * B6 + G3 * C6 + H3) / Sqrt(E3 ^ 2 + F3 ^ 2 + G3 ^ 2) - C5) ^ 2"
Dim ws As Worksheet: Set ws = ActiveSheet
SolverReset
SolverOk setCell:=ws.Range("A7"), _
MaxMinVal: =3,_
ByChange: =ws.Range("A6:C6"), _
EngineDesc: = "GRG Nonlinear"
SolverSolve UserFinish: = True
End Sub
'Results
'Central coordinates 0.2499998190.24999810.250015 of the sphere inscribed in the tetrahedron

``````

2022-09-30 11:10

vba solver (of 4)
I made it a function.[A1 format] has been changed to [R1C1 format].

``````Const Ax=0
Const Ay = 0
Const Az = 0
Const Bx = 1
Const By = 0
Const Bz = 0
Const Cx = 0
Const Cy = 1
Const Cz = 0
Const Dx = 0
Const Dy = 0
Const Dz = 2
Function myHeimen (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
a=(By-Ay)*(Cz-Az)-(Cy-Ay)*(Bz-Az)
b=(Bz-Az)*(Cx-Ax)-(Cz-Az)*(Bx-Ax)
c=(Bx-Ax)*(Cy-Ay)-(Cx-Ax)*(By-Ay)
d=-(a*Ax+b*Ay+c*Az)
myHeimen=Array(a,b,c,d)
End Function
Function mySimentaiTaiseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiTaiseki=_
((x4-x1)*Abs(y2-y1)*(z3-z1)-(z3-z1)*(y3-y1)_
+ (y4-y1)*Abs(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)_
+ (z4-z1)*Abs(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)/6#
End Function
Function myDis(x1,y1,z1,x2,y2,z2)
myDis=Sqr(x1-x2)^2+(y1-y2)^2+(z1-z2)^2)
End Function
Function myHeron (x1, y1, z1, x2, y2, z2, x3, y3, z3)
s=(myDis(x1,y1,z1,x2,y2,z2) + myDis(x2,y2,z2,x3,y3,z3) + myDis(x3,y3,z3,x1,y1,z1)/2#
myHeron=Sqr(s*(s-myDis(x1,y1,z1,x2,y2,z2))*(s-myDis(x2,y2,z2,x3,y3,z3))*(s-myDis(x3,y3,z3,x1,y1,z1))))
End Function
Function mySimentaiMenseki (x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
mySimentaiMenseki=_
myHeron(x1,y1,z1,x2,z2,x3,y3,z3)_
+ myHeron(x2,y2,z2,x3,z3,x4,y4,z4)_
+ myHeron(x3,y3,z3,x4,z4,x1,y1,z1)_
+ myHeron (x4, y4, z4, x1, y1, z1, x2, y2, z2)
End Function
Function myR1C1 toA1(i,j)
myR1C1toA1 = Application.ConvertFormula ("R" & i& "C" & j, xlR1C1, xlA1)
End Function
Function myNainaisetukyu (igyo,iretu,x1,y1,z1,x2,y2,z2,x3,z3,x4,y4,z4)
Dim vD As Variant
Dim vA As Variant
Dim vB As Variant
Dim vC As Variant
'
myTaiseki = mySimentaiTaiseki (Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
myMenseki = mySimentaiMenseki(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
myR = myTaiseki * 3# / myMenseki
vD = myHeimen(Ax, Ay, Az, Bx, By, Bz, Cx, Cy, Cz)
vA = myHeimen(Bx, By, Bz, Cx, Cy, Cz, Dx, Dy, Dz)
vB = myHeimen(Cx, Cy, Cz, Dx, Dy, Dz, Ax, Ay, Az)
'
myD = "(Abs(" & vD(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vD(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vD(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vD(3) & ") / Sqrt(" & vD(0) & " ^ 2 + " & vD(1) & " ^ 2 +" & vD(2) & " ^ 2) - " & myR & ")"
myA = "(Abs(" & vA(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vA(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vA(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vA(3) & ") / Sqrt(" & vA(0) & " ^ 2 + " & vA(1) & " ^ 2 +" & vA(2) & " ^ 2) - " & myR & ")"
myB = "(Abs(" & vB(0) & " * " & myR1C1toA1(igyo, iretu) & "+ " & vB(1) & " * " & myR1C1toA1(igyo, iretu + 1) & "+ " & vB(2) & " * " & myR1C1toA1(igyo, iretu + 2) & "+ " & vB(3) & ") / Sqrt(" & vB(0) & " ^ 2 + " & vB(1) & " ^ 2 +" & vB(2) & " ^ 2) - " & myR & ")"
Range(myR1C1toA1(igyo, iretu + 4)).Formula = "=" & myD & "^ 2 +" & myA & "^ 2 +" & myB & "^ 2"
'
Dim ws As Worksheet: Set ws = ActiveSheet
SolverReset
SolverOk setCell:=ws.Range(myR1C1toA1(igyo, iretu + 4)), _
MaxMinVal:=3, _
ByChange:=ws.Range(myR1C1toA1(igyo, iretu) & ":" & myR1C1toA1(igyo, iretu + 2)), _
EngineDesc:="GRG Nonlinear"
SolverSolve UserFinish:=True

myNainaisetukyu = Array(Range(myR1C1toA1(igyo, iretu)).Value, Range(myR1C1toA1(igyo, iretu + 1)).Value, Range(myR1C1toA1(igyo, iretu)).Value, myR)
End Function
Subaaa_Sankakusui()
Dim myXYZR As Variant
ActiveSheet.Cells.Clear
igyo=1
iretu=4
myXYZR=myNainaisetukyu(igyo,iretu,Ax,Ay,Az,Bx,By,Bz,Cx,Cy,Cz,Cx,Cy,Cz)
Cells(1,1) = Ax
Cells (1, 2) = Ay
Cells(1,3) = Az
Cells(2,1) = Bx
Cells(2,2) = By
Cells(2,3) = Bz
Cells(3,1) = Cx
Cells(3,2) = Cy
Cells(3,3) = Cz
Cells(4,1) = Dx
Cells(4,2) = Dy
Cells(4,3) = Dz
Cells(igyo,iretu+3) = myXYZR(3)
Cells(igyo,iretu+4)=""
End Sub
'Results
'Central coordinates and radius 0.2499998190.24999810.250000150.25 of the sphere inscribed in the tetrahedron
``````

2022-09-30 11:10

## If you have any answers or tips

Popular Tags
python x 4628
android x 1593
java x 1493
javascript x 1425
c x 924
c++ x 877
ruby-on-rails x 696
php x 692
python3 x 683
html x 656