衝撃！！三重らせん模型がExcelの中で回転する！！の作成方法

前回に引き続き、Excel図形機能で複雑な立体模型を作ってみました！今回はらせん模型です！しかも三重らせんです！！
ちゃんと図形(オートシェイプ)でできていますよ！ぜひ下記コードを使って作ってみてください！

#エクセル   #Excel #オートシェイプ #図形 #立体 #立体図形   #立体模型 #グループ化 #解説  #自動化 #excelvba  #vba #分解 #解体 #極座標 #3dart  #3ddrawing #3dmodeling #3drenders #3drendering #3dartwork #3d #3Danimation #3DCG #3Dビューア #3dxanimation #3dxartwork #らせん #三重らせん

この立体模型作成に使うコードは以下の通りです！お手元のExcelVBAにこのコードを貼り付けて、「test_run01()」を実行してみてください！

Sub set_ball(cx_cm, cy_cm, x_cm, y_cm, z_cm, r_cm, bk As Workbook)

cx = Application.CentimetersToPoints(cx_cm)
cy = Application.CentimetersToPoints(cy_cm)
x = Application.CentimetersToPoints(x_cm)
y = Application.CentimetersToPoints(y_cm)
z_ = Application.CentimetersToPoints(z_cm)
r = Application.CentimetersToPoints(r_cm)

Dim sha As Shape
Dim sh As Worksheet
Set sh = bk.Worksheets(1)
Set sha = sh.Shapes.AddShape(msoShapeOval, cx + x - r, cy - y - r, 2 * r, 2 * r)

Dim s3d As ThreeDFormat
Set s3d = sha.ThreeD
s3d.BevelTopInset = r
s3d.BevelTopDepth = r
s3d.BevelBottomInset = r
s3d.BevelBottomDepth = r
s3d.Z = z_


sha.Line.Visible = msoFalse
sha.Fill.ForeColor.RGB = RGB(255 * Abs(y_cm) / 10, 255 * Abs(z_cm) / 10, 255 * (x_cm + 10) / 30)

End Sub
Sub test_run01()
Dim bk As Workbook
Set bk = Workbooks.Add
cx_cm = 20
cy_cm = 20
r_cm = 0.5
Pai = Application.WorksheetFunction.Pi()

'図形の絵画

n = 4
m = 3
For i = 1 To 360 * n
rad = i / 180 * Pai
d = Cos(rad / (2 * n)) ^ 2
For j = 1 To m
Call set_ball(cx_cm, cy_cm, 30 * rad / (2 * Pai * n) - 10, 10 * d * Sin(rad + 2 * Pai / m / 1.3 * j), 10 * d * Cos(rad + 2 * Pai / m / 1.3 * j), r_cm, bk)
Next j
Next i


'図形の名称取得
Dim sh As Worksheet
Set sh = bk.Worksheets(1)
Dim sha_ns()

n = 0
For Each sha_n In sh.Shapes
ReDim Preserve sha_ns(n)
sha_ns(n) = sha_n.Name
n = n + 1
Next

'図形をグループ化、3D回転
Dim s3d As ThreeDFormat
Set s3d = sh.Shapes.Range(sha_ns).Group.ThreeD
s3d.SetPresetCamera (msoCameraPerspectiveContrastingLeftFacing)
s3d.RotationX = 9.5
s3d.RotationY = 308.7
s3d.RotationZ = 18.5
s3d.FieldOfView = 45

bk.Windows(1).Zoom = 45
bk.Windows(1).ScrollColumn = 2
bk.Windows(1).ScrollRow = 4
bk.Activate
DoEvents

'回転アニメーション
Set s3d = sh.Shapes(1).ThreeD
For i = 1 To 20
s3d.IncrementRotationX 20
DoEvents
Application.Wait Now + TimeSerial(0, 0, 0.1)
Next i

For i = 1 To 20
s3d.IncrementRotationY 20
DoEvents
Application.Wait Now + TimeSerial(0, 0, 0.1)
Next i

End Sub