Option Explicit
Option Base 0
'
Private Const CUBEPAIV = 3.141592
Private Const CUBERADI = (CUBEPAIV / 180)
Public Sub 立方体描画マクロ()
Const CUBELEFT = 100 '描画開始位置Ｘ
Const CUBETOPP = 110 ' Ｙ
'
Const CUBEVPIT = 60 '横-間隔
Const CUBEHPIT = 60 '縦-間隔
Const CUBECOLS = 5 '横/描画数
Const CUBEROWS = 4 '縦/描画数
'
Const CUBERATE = 15 'サイズ倍率/x2
Const CUBELNCL = vbBlue '線の色
Const CUBELNWT = 1 '線の太さ
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer
Dim Kp As Integer, Lp As Integer
Dim sngCxp As Single, sngCyp As Single
Dim sngAnX As Single
Dim sngSpt(1) As Single, sngEpt(1) As Single
'
Randomize '乱数系列初期化
For Jp = 0 To CUBEROWS - 1
sngCyp = CUBETOPP + CUBEHPIT * Jp
For Ip = 0 To CUBECOLS - 1
sngCxp = CUBELEFT + CUBEVPIT * Ip
'
'乱数で回転角決定
sngAnX = Int(60 * Rnd + 15) * CUBERADI
For Kp = 1 To 4
'上辺、下辺を描画
For Lp = 1 To 2
Call 三次元回転変換( _
Choose(Kp, -1, 1, 1, -1), _
Choose(Kp, -1, -1, 1, 1), _
Choose(Lp, -1, 1), sngAnX, _
sngSpt(0), sngSpt(1))
Call 三次元回転変換( _
Choose(Kp, 1, 1, -1, -1), _
Choose(Kp, -1, 1, 1, -1), _
Choose(Lp, -1, 1), sngAnX, _
sngEpt(0), sngEpt(1))
'*描画
With ActiveDocument.Shapes.AddLine _
(sngSpt(0) * CUBERATE + sngCxp, _
sngSpt(1) * CUBERATE + sngCyp, _
sngEpt(0) * CUBERATE + sngCxp, _
sngEpt(1) * CUBERATE + sngCyp).Line
.ForeColor.RGB = CUBELNCL
.Weight = CUBELNWT
End With
Next Lp
'側辺を描画
Call 三次元回転変換( _
Choose(Kp, -1, 1, 1, -1), _
Choose(Kp, -1, -1, 1, 1), _
-1, sngAnX, sngSpt(0), sngSpt(1))
Call 三次元回転変換( _
Choose(Kp, -1, 1, 1, -1), _
Choose(Kp, -1, -1, 1, 1), _
1, sngAnX, sngEpt(0), sngEpt(1))
'*描画
With ActiveDocument.Shapes.AddLine _
(sngSpt(0) * CUBERATE + sngCxp, _
sngSpt(1) * CUBERATE + sngCyp, _
sngEpt(0) * CUBERATE + sngCxp, _
sngEpt(1) * CUBERATE + sngCyp).Line
.ForeColor.RGB = CUBELNCL
.Weight = CUBELNWT
End With
Next Kp
Next Ip
Next Jp
End Sub
Public Sub 三次元回転変換(psngXp As Single, _
psngYp As Single, psngZp As Single, _
pAngX As Single, _
ByRef rsngX As Single, ByRef rsngY As Single)
Const CUBEANGY = -60 * CUBERADI 'Ｙ軸、Ｚ軸回りの
Const CUBEANGZ = 0 * CUBERADI ' 回転角は固定！
'---------------------------------------------------------------------------
Dim sngX1 As Single, sngY1 As Single, sngZ1 As Single
Dim sngX2 As Single, sngY2 As Single
'
sngX1 = psngXp * Cos(CUBEANGY) + psngZp * Sin(CUBEANGY)
sngY1 = psngYp
sngZ1 = -1 * psngXp * Sin(CUBEANGY) + psngZp * Cos(CUBEANGY)
sngX2 = sngX1
sngY2 = sngY1 * Cos(pAngX) - sngZ1 * Sin(pAngX)
'
rsngX = sngX2 * Cos(CUBEANGZ) - sngY2 * Sin(CUBEANGZ)
rsngY = sngX2 * Sin(CUBEANGZ) + sngY2 * Cos(CUBEANGZ)
End Sub
