ExcelVBAで数学の教科書にあるような立体図形を描いてみた
この動画のマクロはWindows11/Office2013で作成してます。
Sub Macro_Ex_Wd_Pp()
Dim myDocument
Dim i, x, y, r, h
'Word,Excel,Powerpointどれでも動くようにする
Select Case True
Case Application.Caption = "Word"
Set myDocument = ActiveDocument
Case InStr(Application.Caption, "Excel") > 0
Set myDocument = ActiveSheet
Case Else
Set myDocument = ActivePresentation.Slides(1)
End Select
'今ある図形を消す
For i = myDocument.Shapes.Count To 1 Step -1
myDocument.Shapes(i).Delete
Next i
'図形の表示位置、半径、高さ
x = 150: y = 200
r = 100: h = 100
'球、円柱、円錐
Call Ball(myDocument, x, y, r)
Call Cylinder(myDocument, x, y, r, h)
Call Cone(myDocument, x, y, r, h)
'立方体、四角錐、三角錐
x = 500: y = 100
Call Cube(myDocument, x, y, r)
y = 250
Call Pyramid(myDocument, x, y, r)
y = 350
Call Tetrahedron(myDocument, x, y, r)
End Sub
Function Ball(obj, x, y, r)
'球を描画
' obj 描画するオブジェクト
' 中心(x,y) 半径r
Dim SN(0 To 2) As Variant
Dim shp, a
a = 0.3
'半径
'Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y + r * a / 8, x + r, y + r * a / 8)
'赤道の裏側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8, r * 2, r * a) 'ワードの場合
End If
SN(0) = shp.Name
shp.Adjustments.Item(1) = 180
shp.Adjustments.Item(2) = 0
lineattr shp, msoLineDash, 2 '破線
'赤道の表側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8, r * 2, r * a) 'ワードの場合
End If
SN(1) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 180
lineattr shp, msoLineSolid, 2
'外周
Set shp = obj.Shapes.AddShape(msoShapeOval, x - r / 1, y - r / 1, r * 2, r * 2)
SN(2) = shp.Name
shp.Fill.Visible = msoFalse '円の塗りつぶしなし
lineattr shp, msoLineSolid, 2
'グループ化
obj.Shapes.Range(SN).Group.Name = "球"
Set Ball = shp
End Function
Function Cylinder(obj, x, y, r, h)
'円柱を描画
' obj 描画するオブジェクト
' 上面中心(x,y) 半径r
'y > h+r/2であるべき
Dim SN(0 To 4) As Variant
Dim shp, a
a = 0.3 '楕円の潰れ具合
'半径
'Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y + r * a / 8, x + r, y + r * a / 8)
'上面
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8, r * 2, r * a) 'ワードの場合
End If
SN(0) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 360
lineattr shp, msoLineSolid, 2
'底面の裏側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(1) = shp.Name
shp.Adjustments.Item(1) = -180
shp.Adjustments.Item(2) = 0
lineattr shp, msoLineDash, 2
'底面の表側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(2) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 180
lineattr shp, msoLineSolid, 2
'右の線
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x - r, y + r * a / 8, x - r, y + r * a / 8 + h)
SN(3) = shp.Name
lineattr shp, msoLineSolid, 2
'左の線
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x + r, y + r * a / 8, x + r, y + r * a / 8 + h)
SN(4) = shp.Name
lineattr shp, msoLineSolid, 2
'グループ化
obj.Shapes.Range(SN).Group.Name = "円柱"
Set Cylinder = shp
End Function
Function Cone(obj, x, y, r, h)
'円錐を描画
' obj 描画するオブジェクト
' 頂点(x,y) 半径r
' y > hであるべき
Dim SN(0 To 3) As Variant
Dim shp, a
a = 0.3 '楕円の潰れ具合
'半径
'Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y + r * a / 8 + h, x + r, y + r * a / 8 + h)
'底面の裏側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(0) = shp.Name
shp.Adjustments.Item(1) = 180
shp.Adjustments.Item(2) = 0
lineattr shp, msoLineDash, 2
'底面の表側
If Application.Caption <> "Word" Then
Set shp = obj.Shapes.AddShape(msoShapeArc, x, y - r / 4 + h, r, r * a) 'エクセル・パワポの場合
Else
Set shp = obj.Shapes.AddShape(msoShapeArc, x - r, y - r / 8 + h, r * 2, r * a) 'ワードの場合
End If
SN(1) = shp.Name
shp.Adjustments.Item(1) = 0
shp.Adjustments.Item(2) = 180
lineattr shp, msoLineSolid, 2
'稜線(左)
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y, x - r, y + r * a / 8 + h)
SN(2) = shp.Name
lineattr shp, msoLineSolid, 2
'稜線(右)
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, x, y, x + r, y + r * a / 8 + h)
SN(3) = shp.Name
lineattr shp, msoLineSolid, 2
'グループ化
obj.Shapes.Range(SN).Group.Name = "円錐"
Set Cone = shp
End Function
Function Cube(obj, x, y, r)
'立方体を描画
' obj 描画するオブジェクト
' 重心(x,y,0) 1辺の長さ r
Dim SN(0 To 3) As Variant
Dim shp, i, o, p, rt
'原点(0,0,0)となるOfficeアプリ上の座標
o = Array(x, y, 0)
'原点が重心で辺の長さ1の立方体の頂点の配列
p = Array(Array(-1, 1, -1), _
Array(1, 1, -1), _
Array(1, 1, 1), _
Array(-1, 1, 1), _
Array(-1, -1, -1), _
Array(1, -1, -1), _
Array(1, -1, 1), _
Array(-1, -1, 1))
'座標点をr/2倍する
For i = 0 To UBound(p, 1)
p(i) = MatScl(p(i), r / 2)
Next
'全頂点を回転
rt = Array(30, 20, -20) 'x軸、y軸、z軸の回転角度
For i = 0 To UBound(p, 1)
p(i) = Zrote((Yrote(Xrote(p(i), rt(0)), rt(1))), rt(2))
Next
'辺を書いていく
'表の辺
Set shp = trackline(obj, o, p, Array(5, 4, 7, 6, 5, 1, 2, 3, 7))
Call lineattr(shp, msoLineSolid, 2)
SN(0) = shp.Name
Set shp = trackline(obj, o, p, Array(2, 6))
Call lineattr(shp, msoLineSolid, 2)
SN(1) = shp.Name
'裏の辺
Set shp = trackline(obj, o, p, Array(3, 0, 1))
Call lineattr(shp, msoLineDash, 2)
SN(2) = shp.Name
Set shp = trackline(obj, o, p, Array(0, 4))
Call lineattr(shp, msoLineDash, 2)
SN(3) = shp.Name
'グループ化
obj.Shapes.Range(SN).Group.Name = "立方体"
Set Cube = shp
End Function
Function Pyramid(obj, x, y, r)
'正四角錐を描画
' obj 描画するオブジェクト
' 重心(x,y,0) 1辺の長さ r
Dim SN(0 To 2) As Variant
Dim shp, i, o, p, rt
'原点(0,0,0)となるOfficeアプリ上の座標
o = Array(x, y, 0)
'原点が重心で辺の長さ1の正四面体の頂点の配列
p = Array(Array(0, -3 / Sqr(2) / 2, 0), _
Array(1, 1 / Sqr(2) / 2, 1), _
Array(-1, 1 / Sqr(2) / 2, 1), _
Array(-1, 1 / Sqr(2) / 2, -1), _
Array(1, 1 / Sqr(2) / 2, -1))
'座標点をr/2倍する
For i = 0 To UBound(p, 1)
p(i) = MatScl(p(i), r / 2)
Next
'全頂点を回転
rt = Array(10, 20, 0) 'x軸、y軸、z軸の回転角度
For i = 0 To UBound(p, 1)
p(i) = Zrote((Yrote(Xrote(p(i), rt(0)), rt(1))), rt(2))
Next
'辺を書いていく
'表の辺
Set shp = trackline(obj, o, p, Array(0, 2, 1, 0, 4, 1))
Call lineattr(shp, msoLineSolid, 2)
SN(0) = shp.Name
'裏の辺
Set shp = trackline(obj, o, p, Array(2, 3, 4))
Call lineattr(shp, msoLineDash, 2)
SN(1) = shp.Name
Set shp = trackline(obj, o, p, Array(0, 3))
Call lineattr(shp, msoLineDash, 2)
SN(2) = shp.Name
'グループ化
obj.Shapes.Range(SN).Group.Name = "四角錐"
Set Pyramid = shp
End Function
Function Tetrahedron(obj, x, y, r)
'正四面体を描画
' obj 描画するオブジェクト
' 重心(x,y,0) 1辺の長さ r
Dim SN(0 To 1) As Variant
Dim shp, i, o, p, rt
'原点(0,0,0)となるOfficeアプリ上の座標
o = Array(x, y, 0)
'原点が重心で辺の長さ1の正四面体の頂点の配列
p = Array(Array(0, 0, Sqr(2) / Sqr(3) * (2 / 3)), _
Array(-1 / 2, 1 / Sqr(3) / 2, -Sqr(2) / Sqr(3) / 3), _
Array(1 / 2, 1 / Sqr(3) / 2, -Sqr(2) / Sqr(3) / 3), _
Array(0, -1 / Sqr(3), -Sqr(2) / Sqr(3) / 3))
'座標点をr倍する
For i = 0 To UBound(p, 1)
p(i) = MatScl(p(i), r)
Next
'全頂点を回転
rt = Array(300, 120, -25) 'x軸、y軸、z軸の回転角度
For i = 0 To UBound(p, 1)
p(i) = Zrote((Yrote(Xrote(p(i), rt(0)), rt(1))), rt(2))
Next
'辺を書いていく
'表の辺
Set shp = trackline(obj, o, p, Array(0, 1, 2, 0, 3, 1))
Call lineattr(shp, msoLineSolid, 2)
SN(0) = shp.Name
'裏の辺
Set shp = trackline(obj, o, p, Array(2, 3))
Call lineattr(shp, msoLineDash, 2)
SN(1) = shp.Name
'グループ化
obj.Shapes.Range(SN).Group.Name = "正四面体"
Set Tetrahedron = shp
End Function
Function trackline(obj, o, p, Route)
'点から点への線を描画
Dim shp_Name() As Variant
Dim shp, i
ReDim shp_Name(UBound(Route) - 1)
For i = 0 To UBound(Route) - 1
Set shp = obj.Shapes.AddConnector(msoConnectorStraight, o(0) + Int(p(Route(i + 1))(0)), o(1) + Int(p(Route(i + 1))(1)), o(0) + Int(p(Route(i))(0)), o(1) + Int(p(Route(i))(1)))
shp_Name(i) = shp.Name
'番号をふる(デバック用)
'Set txt = obj.Shapes.AddTextbox(msoTextOrientationHorizontal, o(0) + Int(p(Route(i + 1))(0)), o(1) + Int(p(Route(i + 1))(1)), 20, 20)
'txt.TextFrame.Characters.Text = Route(i + 1)
Next
If UBound(Route) > 1 Then
obj.Shapes.Range(shp_Name).Group.Name = shp_Name(0)
Set trackline = obj.Shapes(shp_Name(0))
Else
Set trackline = shp
End If
End Function
Function lineattr(obj, d, Optional w As Integer = 1, Optional rgb As Long = 12287562)
'線のスタイル、太さ、色(任意)を変更
With obj
.Line.DashStyle = d
.Line.Weight = w
.Line.ForeColor.rgb = rgb
End With
End Function
Function Xrote(v, d) 'vは(x,y,z)座標の配列、dは角度(0-360)
'X軸回転させる
' 1 0 0
' 0 cos sin
' 0 -sin cos
Dim rad_1do
rad_1do = 2 / 360 * 3.141594
Xrote = Array(v(0), Cos(d * rad_1do) * v(1) + Sin(d * rad_1do) * v(2), -Sin(d * rad_1do) * v(1) + Cos(d * rad_1do) * v(2))
End Function
Function Yrote(v, d) 'vは(x,y,z)座標の配列、dは角度(0-360)
'Y軸回転させる
' cos 0 -sin
' 0 1 0
' sin 0 cos
Dim rad_1do
rad_1do = 2 / 360 * 3.141594
Yrote = Array(Cos(d * rad_1do) * v(0) - Sin(d * rad_1do) * v(2), v(1), Sin(d * rad_1do) * v(0) + Cos(d * rad_1do) * v(2))
End Function
Function Zrote(v, d) 'vは(x,y,z)座標の配列、dは角度(0-360)
'Z軸回転させる
' cos sin 0
' -sin cos 0
' 0 0 1
Dim rad_1do
rad_1do = 2 / 360 * 3.141594
Zrote = Array(Cos(d * rad_1do) * v(0) + Sin(d * rad_1do) * v(1), -Sin(d * rad_1do) * v(0) + Cos(d * rad_1do) * v(1), v(2))
End Function
Function MatScl(v, scl)
'(x,y,z)座標の配列の要素をscl倍する
Dim a
a = Array(v(0) * scl, v(1) * scl, v(2) * scl)
MatScl = Array(v(0) * scl, v(1) * scl, v(2) * scl)
End Function