Excel図形絵画(オートシェイプ)で複雑な立体模型を作る方法！！(作成用コードあり！)

Excelの図形絵画機能はみなさんお馴染みだと思いますが、描ける立体模型は単純なものが多いかと思います。そんな図形絵画機能で、ものすごーく複雑な立体模型を作ってみました！
#Excel  #エクセル #図形 #図形絵画 #立体図形  #vba #オートシェイプ

この立体模型作成に使うコードは以下の通りです！お手元のExcelVBAにこのコードを貼り付けて、「test_run01()」を実行してみてください！合計2160個の図形がグループ化されています！

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(x_cm) / 10, 255 * Abs(y_cm) / 10, 255 * Abs(z_cm) / 10)

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 = 6
For i = 1 To 360 * n
rad = i / 180 * Pai
Call set_ball(cx_cm, cy_cm, 10 * Sin(rad / n / 2) * Cos(rad), 10 * Sin(rad / n / 2) * Sin(rad), 10 * Cos(rad / n / 2), r_cm, bk)

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 = 65
bk.Windows(1).ScrollColumn = 5
bk.Windows(1).ScrollRow = 14
bk.Activate
DoEvents

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

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

End Sub

#excelvba  #vba #分解 #解体 #極座標 #3dart  #3ddrawing #3dmodeling #3drenders #3drendering #3dartwork #3d #3Danimation #3DCG #3Dビューア #3dxanimation #3dxartwork