Embedded Files
Excel macro
tomoe-Fill-ouyou
(以下、Sub tomoe()以降最後まで、コピーして、Excelを開いて、tomoe-fill.xlsmと言う名前でファイルを作り、表示クリック、マクロ開く、ここで、マクロの初期作成にためのウインドウが開きます。tomoeとサブルーチン名を入力すると、マクロ作成画面になります。
その画面に、以下のサブルーチンをコピーして貼り付けます。上書き保存です。実行で上記、絵を描きます。）
Sub tomoe()
Set RngStart = Worksheets("Sheet1").Range("B30") ' sonomama copy B23 ?
xs = RngStart.Left ' sonomama copy
ys = RngStart.Top ' sonomama copy
Set RngEnd = Worksheets("Sheet1").Range("F4") ' sonomama copy D4 ?
ye = RngEnd.Top ' sonomama copy
xe = xs + (ys - ye) ' sonomama copy
pai = 3.14159265358979
[A1].Select
Dim x(74) As Double
Dim y(74) As Double
Dim z(74) As Double
Dim xx(74) As Double
Dim yy(74) As Double
dt = 2# * pai / 36#
For i = 1 To 19
x(i) = Cos(dt * (i - 1))
y(i) = Sin((i - 1) * dt)
Next i
For i = 1 To 19
x(i + 19) = 0.5 * Cos((i - 1) * dt + pai) - 0.5
y(i + 19) = 0.5 * Sin((i - 1) * dt + pai)
Next i
For i = 1 To 19
x(i + 38) = 0.5 * Cos((i - 1) * dt + pai) + 0.5
y(i + 38) = 0.5 * Sin((i - 1) * dt)
Next i
xmax = -100000#
ymax = -100000#
xmin = 100000#
ymin = 100000#
For i = 1 To 37 ' sonomama copy i ? 37 ?
If (x(i) > xmax) Then ' sonomama copy i ?
xmax = x(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
If (x(i) < xmin) Then ' sonomama copy i ?
xmin = x(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
If (y(i) > ymax) Then ' sonomama copy i ?
ymax = y(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
If (y(i) < ymin) Then ' sonomama copy i ?
ymin = y(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
Next i ' sonomama copy i ?
'Next ii
If (xmax > ymax) Then ' sonomama copy
ymax = xmax ' sonomama copy
Else ' sonomama copy
xmax = ymax ' sonomama copy
End If ' sonomama copy
If (xmin < ymin) Then ' sonomama copy
ymin = xmin ' sonomama copy
Else ' sonomama copy
xmin = ymin ' sonomama copy
End If ' sonomama copy
dx = (xe - xs) / (xmax - xmin) ' x bairitu sonomama copy
dy = (ye - ys) / (ymax - ymin) ' y bairitu sonomama copy
xg = (xe - xs) * (-xmin / (xmax - xmin)) + xs ' xg is X offset sonomama copy
yg = (ye - ys) * (-ymin / (ymax - ymin)) + ys ' yg is Y offset sonomama copy
ii = 1
'For ii = 1 To 7
icol_red = (7 - ii) * 3
icol_green = 3 * ii
icol_blue = ii * 2
Xnode = x(1) * dx + xg ' Xnode=x(1) sonomama copy
Ynode = y(1) * dy + yg ' Ynode=y(1) sonomama copy
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditineAuto, Xnode, Ynode) ' sonomama copy
For j = 2 To 57
Xnode = x(j) * dx + xg ' Xnode = x(2)-x(5) sonomama copy j ?
Ynode = y(j) * dy + yg ' Ynode = y(2)-y(5) sonomama copy j ?
myBuilder.AddNodes msoSegmentLine, msoEditineAuto, Xnode, Ynode ' sonomama copy
Next j
Set myShape = myBuilder.ConvertToShape ' sonomama copy
With myShape ' sonomama copy
.Fill.ForeColor.RGB = RGB(icol_red * 10, icol_green * 10, icol_blue * 10) ' area nurritubushi ' icol_red icol_green icol_blue kaeru atoha sonomama copy
.Line.ForeColor.RGB = RGB(icol_red * 10, icol_green * 10, icol_blue * 10) ' area gaisyuu line ' icol_red icol_green icol_blue kaeru atoha sonomama copy
.Line.Weight = 0# ' sonomama copy
End With ' sonomama copy
dt = 2# * pai / 36#
For i = 1 To 19
x(i) = Cos(dt * (i - 1))
y(i) = -Sin((i - 1) * dt)
Next i
For i = 1 To 19
x(i + 19) = 0.5 * Cos((i - 1) * dt + pai) - 0.5
y(i + 19) = 0.5 * Sin((i - 1) * dt + pai)
Next i
For i = 1 To 19
x(i + 38) = 0.5 * Cos((i - 1) * dt + pai) + 0.5
y(i + 38) = 0.5 * Sin((i - 1) * dt)
Next i
For i = 1 To 37 ' sonomama copy i ? 37 ?
If (x(i) > xmax) Then ' sonomama copy i ?
xmax = x(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
If (x(i) < xmin) Then ' sonomama copy i ?
xmin = x(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
If (y(i) > ymax) Then ' sonomama copy i ?
ymax = y(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
If (y(i) < ymin) Then ' sonomama copy i ?
ymin = y(i) ' sonomama copy i ?
Else ' sonomama copy
End If ' sonomama copy
Next i ' sonomama copy i ?
'Next ii
If (xmax > ymax) Then ' sonomama copy
ymax = xmax ' sonomama copy
Else ' sonomama copy
xmax = ymax ' sonomama copy
End If ' sonomama copy
If (xmin < ymin) Then ' sonomama copy
ymin = xmin ' sonomama copy
Else ' sonomama copy
xmin = ymin ' sonomama copy
End If ' sonomama copy
dx = (xe - xs) / (xmax - xmin) ' x bairitu sonomama copy
dy = (ye - ys) / (ymax - ymin) ' y bairitu sonomama copy
xg = (xe - xs) * (-xmin / (xmax - xmin)) + xs ' xg is X offset sonomama copy
yg = (ye - ys) * (-ymin / (ymax - ymin)) + ys ' yg is Y offset sonomama copy
ii = 2
icol_red = (4 - ii) * 3
icol_green = 3 * ii
icol_blue = ii * 5
Xnode = x(1) * dx + xg ' Xnode=x(1) sonomama copy
Ynode = y(1) * dy + yg ' Ynode=y(1) sonomama copy
Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode) ' sonomama copy
For j = 2 To 57
Xnode = x(j) * dx + xg ' Xnode = x(2)-x(5) sonomama copy j ?
Ynode = y(j) * dy + yg ' Ynode = y(2)-y(5) sonomama copy j ?
myBuilder.AddNodes msoSegmentLine, msoEditineAuto, Xnode, Ynode ' sonomama copy
Next j
Set myShape = myBuilder.ConvertToShape ' sonomama copy
With myShape ' sonomama copy
.Fill.ForeColor.RGB = RGB(icol_red * 10, icol_green * 10, icol_blue * 10) ' area nurritubushi ' icol_red icol_green icol_blue kaeru atoha sonomama copy
.Line.ForeColor.RGB = RGB(icol_red * 10, icol_green * 10, icol_blue * 10) ' area gaisyuu line ' icol_red icol_green icol_blue kaeru atoha sonomama copy
.Line.Weight = 0# ' sonomama copy
End With
End Sub
Page updated
Google Sites
Report abuse