森と泉ホームページ:エクセルで遊ぼう forest and spring:excel

クリスマスツリー作画　　　　　　　　　エクセルで遊ぼう　作画　製本　問題　作曲

クリスマスツリーを部屋に飾りたいけどお金がないなー。

パソコンでがむしゃらに作っちゃえ！

図形の星と円を使ってクリスマスツリーを描かせよう。
1.セルの塗りつぶしで背景を作る(黒～暗いマゼンタ)
2.図形の星をランダムに散りばめる(白)
3.図形の円でランダムに葉を散りばめる(緑で濃淡あり)
4.図形の円でランダムに飾りを散りばめる（黄・水色・赤で濃淡あり）
5.図形の円でランダムに雪を散りばめる(白～灰色)
3～5は大きさをを多少バラつかせ、全体としてツリーの三角形にする

Option Explicit

Sub xmastree()
Dim i, j, r1, r2, c, r, g, b As Integer
Dim x As Single
Sheets.Add After:=ActiveSheet
r = 0: g = 0: b = 0
For i = 1 To 17 '空
For j = 1 To 4
Cells(i, j).Select
r = r + 2: b = b + 2
Selection.Interior.Color = RGB(r, g, b)
Next
Next
For i = 1 To 400 '星
r2 = Int(Rnd(1) * 200): r1 = Int(Rnd(1) * 220)
c = Int(Rnd(1) * 3) + 2
ActiveSheet.Shapes.AddShape(msoShape4pointStar, r1, r2, c, c).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(255, 255, 255)
.Visible = msoTrue
.Solid
End With
Selection.ShapeRange.Line.Visible = msoFalse
Next
For i = 1 To 800 '葉
r2 = Int(Rnd(1) * 280): r1 = 100 - r2 / 2 + Int(Rnd(1) * r2)
ActiveSheet.Shapes.AddShape(msoShapeOval, r1, r2, 1 + Sqr(r2), 1 + Sqr(r2)).Select
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(0, 160 - Rnd(1) * 60, 0)
.Visible = msoTrue
.Solid
End With
Selection.ShapeRange.Line.Visible = msoFalse
Next
For i = 1 To 90'飾り(赤・黄・水色)
r2 = Int(Rnd(1) * 280): r1 = 100 - r2 / 2 + Int(Rnd(1) * r2)
ActiveSheet.Shapes.AddShape(msoShapeOval, r1, r2, 1 + Sqr(r2), 1 + Sqr(r2)).Select
x = Rnd(1)
With Selection.ShapeRange.Fill
If x < 0.33 Then
.ForeColor.RGB = RGB(255 - Rnd(1) * 55, Rnd(1) * 55, Rnd(1) * 55)
ElseIf x < 0.66 Then
.ForeColor.RGB = RGB(255 - Rnd(1) * 55, 255 - Rnd(1) * 55, Rnd(1) * 55)
Else
.ForeColor.RGB = RGB(Rnd(1) * 55, 255 - Rnd(1) * 55, 255 - Rnd(1) * 55)
End If
.Visible = msoTrue
.Solid
End With
Selection.ShapeRange.Line.Visible = msoFalse
Next
For i = 1 To 200 '雪
r2 = Int(Rnd(1) * 230): r1 = 100 - r2 / 2 + Int(Rnd(1) * r2)
ActiveSheet.Shapes.AddShape(msoShapeOval, r1, r2, 1 + Sqr(r2) / 2, 1 + Sqr(r2) / 2).Select
x = Rnd(1) * 55
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(255 - x, 255 - x, 255 - x)
.Visible = msoTrue
.Solid
End With
Selection.ShapeRange.Line.Visible = msoFalse
Next
End Sub