エクセルVBA フリーハンドで円を描くには

質問

エクセルVBAで円弧と直線がつながった図形を作成し、塗りつぶしたいです。
例えば小判型の図形を円弧情報と直線情報から描いて塗りつぶしたいです。

円弧は中心点と角度情報がありますので、円弧は引けますが最後複合図形にして塗りつぶしできないですので円弧のままではだめです。

考えたのは、
・円弧を書いて、円弧からVerticesで点情報を取得してフリーフォームで書く
　→フリーフォームでない図形は点情報を取得でいない
　→図形をフリーフォームに変換できない
・円弧の頂点のコントロールポイント位置を参考にルールを見つける
　→円弧の頂点A,Bを三等分し、点C,Dを定義。中心からそのCに向かって引いた線とAの接線の交点にコントロールポイントを配置
　　→微妙にずれる

円弧をフリーフォームに変換する方法はありませんか？
円弧を「頂点の編集」にしたときにどういったアルゴリズムでコントロールポイントを出しているか数式はわかりませんか？

回答No.7

SI299792 · ベストアンサー

プログラムを上げていただき、ありがとうございます。
　私のもやってみました。７点取ることで、それらしい図形はできました。但し、120゜（このプログラムでは60）を超えると、９点取ったほうがいいみたいです。
バームクーヘンに四角を付けるといっていたので、180゜以上は試していません。
　新しいプログラムでは、ポイント数を付けました。省略時は３になり、７点取ります。４だと９点取ります。
'
Option Explicit
'　 画面の色取得用
Type Point
　　X As Single
　　Y As Single
End Type
'
Sub Macro3()
'
　　ArcRect2 100, 200, 100, 20, 20
　　Selection.ShapeRange.Line.ForeColor.RGB = vbRed
　　Selection.ShapeRange.Fill.ForeColor.RGB = vbRed
　　ArcRect2 300, 200, 100, 40, 20
　　Selection.ShapeRange.Line.ForeColor.RGB = vbBlue
　　Selection.ShapeRange.Fill.ForeColor.RGB = vbBlue
　　ArcRect2 500, 200, 100, 70, 20, 4
　　Selection.ShapeRange.Line.ForeColor.RGB = vbGreen
　　Selection.ShapeRange.Fill.ForeColor.RGB = vbGreen
End Sub
'
Sub ArcRect2(X As Single, Y As Single, R As Single, A As Integer, H As Single, _
　 Optional P As Integer = 3)
'　 中心点Ｘ，中心点Ｙ，半径，角度，高さ，ポイント数
　　Dim Point As Point
　　Dim Angle As Single
　　Dim S As Single
'
　　S = A / P
　　Point = PointCalc(X, Y + H, R, 90 - A)
　　With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Point.X, Point.Y)
'
　　For Angle = 90 - A + S To 91 + A Step S
　　　　Point = PointCalc(X, Y + H, R, Angle)
　　　　.AddNodes msoSegmentCurve, msoEditingAuto, Point.X, Point.Y
　　Next Angle
　　.AddNodes msoSegmentLine, msoEditingAuto, Point.X, Point.Y
'
　　Point = PointCalc(X, Y, R, 270 - A)
　　.AddNodes msoSegmentLine, msoEditingAuto, Point.X, Point.Y
'
　　For Angle = 270 - A To 271 + A Step S
　　　　Point = PointCalc(X, Y, R, Angle)
　　　　.AddNodes msoSegmentCurve, msoEditingAuto, Point.X, Point.Y
　　Next Angle
　　.ConvertToShape.Select
　　End With
End Sub
'
Function PointCalc(X As Single, Y As Single, R As Single, A As Single) As Point
'
　　Const DTR As Single = 0.01745329
'
　　PointCalc.X = Cos(A * DTR) * R + X
　　PointCalc.Y = Sin(A * DTR) * R + Y
End Function

お礼

色々試していただきありがとうございます。
msoEditingAutoでいい感じになるんですね。
円と重ねてみましたが、円弧の途中はばっちりです。が、端の直線との接続ポイントのコントロールポイントが円弧の接線上ではなく、円弧上に来てしまっています。惜しいです。余分にポイントを置いてから削除するみたいなことができればよいかもしれません。考えてみます。

回答No.6

SI299792

かといって、計算で四角の位置を出すと、ずれが発生します。
'
Sub ChordRect(ByVal X As Long, ByVal Y As Long, R As Long, ByVal A As Integer, _
　 H As Long)
'　 中心点Ｘ，中心点Ｙ，半径，角度，高さ
　　Const DTR As Single = 0.01745329
　　Dim Xf As Long
　　Dim Yf As Long
'
　　Xf = X - R
　　Yf = Y - R
　　ActiveSheet.Shapes.AddShape(msoShapeChord, Xf, Yf, R * 2, R * 2).Select
　　Selection.ShapeRange.Adjustments.Item(1) = 270 - A * 2
　　Selection.ShapeRange.IncrementRotation A
　　ActiveSheet.Shapes.AddShape(msoShapeChord, Xf, Yf + H, R * 2, R * 2).Select
　　Selection.ShapeRange.Adjustments.Item(1) = 270 - A * 2
　　Selection.ShapeRange.IncrementRotation A + 180
　　A = 270 - A
　　Xf = Cos(A * DTR) * R + X
　　Yf = Sin(A * DTR) * R + Y
　　A = A + 180
　　X = Cos(A * DTR) * R + X - Xf
　　Y = Sin(A * DTR) * R + Y - Yf + H
　　ActiveSheet.Shapes.AddShape(msoShapeRectangle, Xf, Yf, X, Y).Select
　　With ActiveSheet.Shapes
　　ActiveSheet.Shapes.Range(Array(.Count - 2, .Count - 1, .Count)).Select
　　End With
　　Selection.ShapeRange.Group.Select
End Sub
画面の色で四角の位置を修正するということも考えましたが、挫折しました。

お礼

トライありがとうございます。
私も試行錯誤を続けていましたが、以下でそれっぽくなりました。
円弧は90度以下になるように分割。
分割後の円弧(例：90度)を三等分した角度*(29/30)(例：29度)をシータ１、円弧の両端点をA,B、Aから29度の中心からの線とAの接線の交点にコントロールポイントを配置、Bも同様に配置する。
三等分した角度からちょっと小さくするのがポイントのようですが、なぜ29/30なのかは不明です。現物合わせです。円弧角90度、45度、22.5度でOKでしたので、全部の角度行けそうです。半径が小さいと値丸めのせいなのか円弧の点自体がずれます。singleでだめ、直接値を入れてもダメでした。これなもう許容しようと思います。

補足

29/30の補正ではだめでした。(-1.1077 * (角度+ 30.67) / 30
角度と比例させた値にするとよさそうです。これだとほぼOKです。
Sub TestFreeFormCircle()

Dim x, y, r As Integer
Dim i As Integer
Dim dividAngle() As Single
Dim AngleS, AngleE, AngleDiff As Single
Dim dividNum As Integer
Dim d1, d2, x1, y1 As Single
Dim CP1x, CP1y, Px, Py, CP2x, CP2y As Single
Dim FreeForm As Object

x = 150
y = 150
r = 50
AngleS = -Atn(1) '-3～0～3くらい
AngleE = Atn(1) * 4 '-3～0～3くらい

ReDim dividAngle(0)
dividAngle(0) = AngleS
AngleDiff = AngleS - AngleE

For dividNum = 1 To 5
If Abs(AngleDiff) / dividNum < Atn(1) * 2 Then
Exit For
End If
Next

For i = 1 To dividNum
ReDim Preserve dividAngle(i)
dividAngle(i) = AngleS - (i) * AngleDiff / dividNum
Next

d1 = dividAngle(0)
x1 = x + r * Cos(d1)
y1 = y + r * Sin(d1)
Set FreeForm = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x1, y1)

For i = 0 To UBound(dividAngle) - 1
d1 = dividAngle(i)
d2 = dividAngle(i + 1)
CP1x = x1 - r * Tan((d2 - d1) * (-1.1077 * (d2 - d1) + 30.67) / 30 / 3) * Cos(Atn(1) * 2 - (d1))
CP1y = y1 + r * Tan((d2 - d1) * (-1.1077 * (d2 - d1) + 30.67) / 30 / 3) * Sin(Atn(1) * 2 - (d1))
Px = x + r * Cos(d2)
Py = y + r * Sin(d2)
CP2x = Px + r * Tan((d2 - d1) * (-1.1077 * (d2 - d1) + 30.67) / 30 / 3) * Cos(Atn(1) * 2 - (d2))
CP2y = Py - r * Tan((d2 - d1) * (-1.1077 * (d2 - d1) + 30.67) / 30 / 3) * Sin(Atn(1) * 2 - (d2))
FreeForm.AddNodes msoSegmentCurve, msoEditingCorner, CP1x, CP1y, CP2x, CP2y, Px, Py
x1 = Px
y1 = Py
Next

FreeForm.ConvertToShape.Select
end sub

回答No.5

SI299792

フリーハンドで円弧と線を描いて、繋げます。
中心点と角度で指定します。
中心点Ｘ，中心点Ｙ，半径，角度，長さ，密度
角度： 0～90です。０で四角。90で半円と四角になります。
長さ：半径との差を指定します。０で半径と長さが同じになります。
密度、省略可。数を多くすると荒くなります。
'
Option Explicit
'
Sub Macro1()
'
　　Arc 300, 200, 100, 60, 0
　　Selection.ShapeRange.Line.ForeColor.RGB = 255
　　Selection.ShapeRange.Fill.ForeColor.RGB = 255
End Sub
'
Sub Arc(X As Single, Y As Single, R As Single, A As Integer, H As Single, _
　 Optional s As Integer = 1)
'　 中心点Ｘ，中心点Ｙ，半径，角度，高さ，密度
　　Const DTR As Single = 0.01745329
　　Dim Xs As Single
　　Dim Ys As Single
　　Dim Xp As Single
　　Dim Yp As Single
　　Dim Angle As Integer
'
　　Angle = 90 - A
　　Xs = Cos(Angle * DTR) * R + X
　　Ys = Sin(Angle * DTR) * R + Y
　　With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Xs, Ys)
'
　　For Angle = 90 - A + s To 90 + A Step s
　　　　Xp = Cos(Angle * DTR) * R + X
　　　　Yp = Sin(Angle * DTR) * R + Y + H
　　　　.AddNodes msoSegmentLine, msoEditingAuto, Xp, Yp
　　Next Angle
'
　　For Angle = 270 - A To 270 + A Step s
　　　　Xp = Cos(Angle * DTR) * R + X
　　　　Yp = Sin(Angle * DTR) * R + Y
　　　　.AddNodes msoSegmentLine, msoEditingAuto, Xp, Yp
　　Next Angle
　　.AddNodes msoSegmentLine, msoSegmentLine, Xs, Ys
　　.ConvertToShape.Select
　　End With
End Sub

お礼

回答ありがとうございます。
確かにこれだとそれらしく図形ができるので、最終手段ですね。
これだとポイント情報が増えるので、気になります。
円で比較すると4点でよいものが360点、コントロールポイントを含めるとを含めると270倍のデータ量になっていしまいます。

回答No.4

Chiquilin

バージョンが書かれてませんけど PowerPointがあるなら
図形の切り抜き機能があるので そっちで対応したらどう
ですか？

PowerPoint で図形を融合したり切り抜いたりする
https://www.cresco.co.jp/blog/entry/1753/

お礼

回答ありがとうございます。
説明不足で済みません。データ元は2次元CADです。
直線なら点情報、円弧なら中心座標と半径、角度の情報が入っています。
例えば3/4のバウムクーヘンの断面を塗りつぶしたいです。

回答No.3

tsubu-yuki

んー・・謎が多いです。
まず
> 複合図形
というのが何なのかよく解らなかったりしますが・・
グループ化のことでしょうか。

そうだったとして、
> 円弧情報と直線情報から描いて塗りつぶしたい
何故直線なのでしょう？長方形では事足りませんか？
円弧の内側を塗りつぶすのは可能ですし、長方形も塗りつぶせます。
これらを「うまく」組み合わせれば良いと思うのですが。

> 円弧は引けますが（略）円弧のままではだめ
塗りつぶせていないのは「直線」の方だと思いますよ。

> 円弧と直線がつながった図形を作成し、塗りつぶし
> 例えば小判型の図形
フローチャートの「端子」や「論理積ゲート」では足りない、
という事でしょうか。

否定ばかりでは進まないので、とりあえず。
直接の回答にはなり得ませんが、
「角丸四角形」を使って、黄色のハンドルを動かして
小判型・・というかなんというか、近いものは表現できますよ。

例えば
　　ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 54, 13.5, 162, 67.5). Select
　　Selection.ShapeRange.Adjustments.Item(1) = 0.5
こんな感じ。

言わずもがな、msoShapeRoundedRectangle = 角丸四角形 で
　　ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 左位置, 上位置, 幅, 高さ)
で指定。
丸みは
　　Selection.ShapeRange.Adjustments.Item(1) = 数値
で調節、「０」指定で完全に長方形（意味は無いですが）、
「０．５」が最高値で、短辺が半円型になります。
　　※０．５を超える数値でもエラーにはなりませんが、
　　　半円を超える形は作れません。

以上、参考にどうぞ。

お礼

回答ありがとうございます。
たとえが悪かったです。小判型だけでなく、3/4に切ったバウムクーヘンのような円弧と直線の組み合わせを塗りつぶしたいです。
データ元は2次元CADで、直線なら点情報、円弧なら中心座標と半径、角度の情報が入っています。

回答No.2

SI299792

フリーフォームで円弧を描く、できないこともないけれど、時間がかかる上、メモリーも食います。
小判型を描いて塗りつぶすなら、やはり、円弧と四角を組み合わせたほうがいいと思います。
円弧を縦横比同じに描いた後、
　　Selection.ShapeRange.Adjustments.Item(1) = 90
を指定すれば、正確な位置に半円を描けます。
後は回転させればいいです。

以下は、小判型を描くサブルーチンです。
左端位置，上端位置，幅，高さ，色を指定します。
横長オンリーですが、連結してセレクトされるので、回転も可能です。
'
Sub Macro1()
'
　　Oval 100, 100, 120, 100, 255
　　Selection.ShapeRange.IncrementRotation 90
　　Oval 300, 100, 140, 100, 65280
　　Selection.ShapeRange.IncrementRotation 90
　　Oval 500, 100, 160, 100, 16711680
　　Selection.ShapeRange.IncrementRotation 90
End Sub
'
Sub Oval(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, IColor As Long)
'
　　ActiveSheet.Shapes.AddShape(msoShapeChord, X1, Y1, Y2, Y2).Select
　　Selection.ShapeRange.Adjustments.Item(1) = 90
　　ActiveSheet.Shapes.AddShape(msoShapeRectangle, X1 + Y2 / 2, Y1, X2 - Y2, Y2).Select
　　ActiveSheet.Shapes.AddShape(msoShapeChord, X1 + X2 - Y2, Y1, Y2, Y2).Select
　　Selection.ShapeRange.Adjustments.Item(1) = 90
　　Selection.ShapeRange.IncrementRotation 180
　　With ActiveSheet.Shapes
　　ActiveSheet.Shapes.Range(Array(.Count - 2, .Count - 1, .Count)).Select
　　End With
　　Selection.ShapeRange.Group.Select
　　Selection.ShapeRange.Line.ForeColor.RGB = IColor
　　Selection.ShapeRange.Fill.ForeColor.RGB = IColor
End Sub

お礼

回答ありがとうございます。
たとえが悪かったです。小判型だけでなく、3/4に切ったバウムクーヘンのような円弧と直線の組み合わせを塗りつぶしたいです。

回答No.1

NuboChan

ExcelでなくてVisioを利用する選択肢は無いですか？

図形の作成は、Visioにまかせて画像はExcelに貼り付けるとかは？