2-8ーhartー塗り潰しー応用

Excel  macro 

hart-Fill-ouyou

(以下、Sub hart()以降最後まで、コピーして、Excelを開いて、hart-fill.xlsmと言う名前でファイルを作り、表示クリック、マクロ開く、ここで、マクロの初期作成にためのウインドウが開きます。hartとサブルーチン名を入力すると、マクロ作成画面になります。

その画面に、以下のサブルーチンをコピーして貼り付けます。上書き保存です。実行で上記、絵を描きます。）

Sub hart()

      Set RngStart = Worksheets("Sheet1").Range("B23")     ' sonomama copy    B23  ?

      xs = RngStart.Left                                   ' sonomama copy

      ys = RngStart.Top                                    ' sonomama copy

      Set RngEnd = Worksheets("Sheet1").Range("D4")        ' sonomama copy    D4  ?

      ye = RngEnd.Top                                      ' sonomama copy

      xe = xs + (ys - ye)                                  ' sonomama copy

      [A1].Select

      Dim x(3000) As Double

      Dim y(3000) As Double

      Dim z(3000) As Double

      Dim xx(1000) As Double

      Dim yy(1000) As Double

      For i = 1 To 201

      x(i) = (i - 1) * 0.005

      y(i) = (x(i) ^ (2 / 3) + Sqr(1# - x(i) * x(i))) * 2# / 3#

      Next i

      For i = 202 To 401

      x(i) = -(i - 201) * 0.005 + 1#

      y(i) = (x(i) ^ (2 / 3) - Sqr(1# - x(i) * x(i))) * 2 / 3#

      Next i

      For i = 401 To 801

      x(i) = -x(801 - i)

      y(i) = y(801 - i)

      Next i

      x(802) = x(1)

      y(802) = y(1)

      For i = 1 To 802

      x(i + 802) = x(i) / 3# + 1.1

      y(i + 802) = y(i) / 3# + 1.1

      Next i

      For i = 1 To 802

      x(1604 + i) = x(i) / 5# + 1.2

      y(1604 + i) = y(i) / 5# + 0.3

      Next i

      n = 2406

      xmax = -100000#

      ymax = -100000#

      xmin = 100000#

      ymin = 100000#

      For i = 1 To 2406          ' sonomama copy       i  ?    2406 ?

      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  ?

      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

      icol_red = 255

      icol_green = 0

      icol_blue = 0

       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 802                 '  1st hart No. 1 to 802

       Xnode = x(j) * dx + xg           '  Xnode = x(2)-x(13)             sonomama copy   j ?

       Ynode = y(j) * dy + yg           '  Ynode = y(2)-y(13)             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, icol_green, icol_blue)   ' area nurritubushi      ' sonomama copy

       .Line.ForeColor.RGB = RGB(icol_red, icol_green, icol_blue)   ' area gaisyuu line      ' sonomama copy

       .Line.Weight = 1.5                                                                    ' sonomama copy

       End With       ' sonomama copy

      icol_red = 255

      icol_green = 100

      icol_blue = 0

       Xnode = x(803) * dx + xg            '   Xnode=x(1)                   sonomama copy

       Ynode = y(803) * dy + yg            '   Ynode=y(1)                   sonomama copy

       Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)   ' sonomama copy

       For j = 804 To 1604              '  2nd hart  Point No. 803 to 1604

       Xnode = x(j) * dx + xg           '  Xnode = x(2)-x(13)             sonomama copy   j ?

       Ynode = y(j) * dy + yg           '  Ynode = y(2)-y(13)             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, icol_green, icol_blue)   ' area nurritubushi      ' sonomama copy

       .Line.ForeColor.RGB = RGB(icol_red, icol_green, icol_blue)   ' area gaisyuu line      ' sonomama copy

       .Line.Weight = 1.5                                                                    ' sonomama copy

       End With       ' sonomama copy

      icol_red = 255       '0-255

      icol_green = 0       '0-255

      icol_blue = 255      '0-255

       Xnode = x(1605) * dx + xg            '   Xnode=x(1)                   sonomama copy

       Ynode = y(1605) * dy + yg            '   Ynode=y(1)                   sonomama copy

       Set myBuilder = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xnode, Ynode)   ' sonomama copy

       For j = 1606 To 2406             '  3rd hart point No. 1605 to 2406

       Xnode = x(j) * dx + xg           '  Xnode = x(2)-x(13)             sonomama copy   j ?

       Ynode = y(j) * dy + yg           '  Ynode = y(2)-y(13)             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, icol_green, icol_blue)   ' area nurritubushi      ' sonomama copy

       .Line.ForeColor.RGB = RGB(icol_red, icol_green, icol_blue)   ' area gaisyuu line      ' sonomama copy

       .Line.Weight = 1.5                                                                    ' sonomama copy

       End With       ' sonomama copy

      End Sub