[[20210506063708]]　『角度を指定して作図できますか』（図景）　ページの最後に飛ぶ

『角度を指定して作図できますか』（図景）

お世話になります。
図形を書く際、角度を指定して作図できますか？
例えば
　・130度　40度　10度　の三角形
　・　＞　この角度を63度に指定　　など

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

 参考過去ログです。

[[20111209164219]]　『角度と斜辺を求める関数』（ミサ

 このスレッドで出てきたキーワードを参考にネット検索してみてください。
（OK） 2021/05/06(木) 08:13

 CADソフトがあるのなら、面倒な計算しなくても
 始点、角度、（一つの）辺の長さを与えたら自動
 計算してくれるかもしれません。
（OK） 2021/05/06(木) 08:17

 三角形を作図するには、３つの頂点の座標(X/Y)
 が必要になります。
 3つも頂点の座標が決まったら、順に頂点から頂点
 に線を引いていくだけです。

 内容は詳しく見てませんが、↓が参考になりそうです。
http://yamav102.cocolog-nifty.com/blog/2012/02/post-1e09.html
（OK） 2021/05/06(木) 10:12

中心点から、一つ目の頂点のベクトルの回転になるから
sin.cosin使って開始角回した点を一点目として、
120度回した二点を結べばよいです

参考程度に、
三角形の、内接円、外接円
http://excel-mania.com/math/t031.html
（ん～？） 2021/05/06(木) 11:04

 こんばんは！
どの程度の精度を求めるかですけど、、まぁ、大体でよければ。。。

 1.挿入→図形→線→Alt+　描きたい三角形の頂点から左右の線より長めに上下に2本引きます。
2.その線を選択→サイズ→回転→角度を合わせます。今回の場合は63度と-28度くらい
3.その両線を↑や←→キーを使って多少はみ出るくらい重ねます。ちょうど山が出来る様に
4.最後に底辺となる線を図形からAltを押しながら左右に引きます。
5.この底辺を山の図形に↑や←→キーを使って多少はみ出るくらいに重ねます。この3本の図形をグループ化します。
6.挿入→図形→二等辺三角形→頂点や大きさを先ほどのグループ化した図形を元に重ねて調整します。
　最初に作った図形をガイドにするのですね。

 すると大体の図は出来るかと思います。

 図を書くときはAltを押しながら書くのがポイントです。

 ちなみにそのむかぁ～～し↓こんなコードを書いていました。
一辺と両サイドの二角から残りの角度と二辺を求めるものです。
With Application
    展開角度左 = 180 - 角度中心 - 角度右
    F = 辺の長さ中心から右 / Sin(.Radians(展開角度左))
    辺の長さ左から中心 = F * Sin(.Radians(角度右))
    辺の長さ左から右 = F * Sin(.Radians(角度中心))
End With

 あってるかどうかわかりませんけど、、
二辺と中心の角度から残りの一辺と二角を求めるコードも書いてました。。。
With Application    
    辺の長さ中心から右 = Sqr(辺の長さ左から中心 ^ 2 + 辺の長さ左から右 ^ 2 - 2 * 辺の長さ左から中心 * 辺の長さ左から右 * Cos(.Radians(角度左)))    
    F = 辺の長さ中心から右 / Sin(.Radians(角度左))    
    展開角度右 = .Degrees(Arcsin(辺の長さ左から中心 / F))    
    展開角度中心 = .Degrees(Arcsin(辺の長さ左から右 / F))   
End With

 よかったら試してみてください。。
わちきは何をしてたんでしょうね(^^;
では、、では、、

  すみません。別でユーザー定義を作っていました。m(__)m
'アークサイン
Public Function Arcsin(x As Double)
    Arcsin = Atn(x / Sqr(-x * x + 1))
End Function
'アークコサイン
Public Function Arccos(x As Double)
    Arccos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End Function
（SoulMan） 2021/05/06(木) 21:25

 ついでに自分のPCを調べてみましたら↓こんなのが出てきました。。。
筆跡からして自分が書いたもののようですが？？？？
何かの参考になるかもしれませんのでUpしておきます。
私も何かの時に使うかもしれませんので。。。多分、、使わないとは思いますが。。。(^^;

 Option Explicit
Public x As Double
Sub さんかく()
Range("a1").Value = Angle3(3, 4, 5)
Range("a2").Value = Angle3(4, 3, 5)
Range("a3").Value = Angle3(5, 4, 3)
End Sub
Public Static Function Angle3(side_a, side_b, side_c)
Dim AngArray(2)
Dim xa As Double
Dim a As Double, b As Double, c As Double
a = side_a: b = side_b: c = side_c
xa = (b ^ 2 + c ^ 2 - a ^ 2) / (2 * b * c)
AngArray(0) = Arccos(xa) * 180 / 3.141592654
b = side_a: c = side_b: a = side_c
xa = (b ^ 2 + c ^ 2 - a ^ 2) / (2 * b * c)
AngArray(1) = Arccos(xa) * 180 / 3.141592654
c = side_a: a = side_b: b = side_c
xa = (b ^ 2 + c ^ 2 - a ^ 2) / (2 * b * c)
AngArray(2) = Arccos(xa) * 180 / 3.141592654
Angle3 = AngArray()
End Function
'セカント
Public Function Sec(x)
Sec = 1 / Cos(x)
End Function
'コセカント
Public Function Cosec(x)
Cosec = 1 / Sin(x)
End Function
'コタンジェント
Public Function Cotan(x)
Cotan = 1 / Tan(x)
End Function
'アークサイン
Public Function Arcsin(x)
Arcsin = Atn(x / Sqr(-x * x + 1))
End Function
'アークコサイン
Public Function Arccos(x)
Arccos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End Function
'アークセカント
Public Function Arcsec(x)
Arcsec = Atn(x / Sqr(x * x - 1)) + Sgn((x) - 1) * (2 * Atn(1))
End Function
'アークコセカント
Public Function Arccosec(x)
Arccosec = Atn(x / Sqr(x * x - 1)) + (Sgn(x) - 1) * (2 * Atn(1))
End Function
'アークコタンジェント
Public Static Function Arccotan(x)
Arccotan = Atn(x) + 2 * Atn(1)
End Function
'双曲線サイン
Public Function HSin(x)
HSin = (Exp(x) - Exp(-x)) / 2
End Function
'双曲線コサイン
Public Function HCos(x)
HCos = (Exp(x) + Exp(-x)) / 2
End Function
'双曲線タンジェント
Public Function HTan(x)
HTan = (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
End Function
'双曲線セカント
Public Function HSec(x)
HSec = 2 / (Exp(x) + Exp(-x))
End Function
'双曲線コセカント
Public Function HCosec(x)
HCosec = 2 / (Exp(x) - Exp(-x))
End Function
'双曲線コタンジェント
Public Sub HCotan(x)
HCotan = (Exp(x) + Exp(-x)) / (Exp(x) - Exp(-x))
End Sub
'双曲線アークサイン
Public Function HArcsin(x)
HArcsin = Log(x + Sqr(x * x + 1))
End Function
'双曲線アークコサイン
Public Function HArccos(x)
HArccos = Log(x + Sqr(x * x - 1))
End Function
'双曲線アークタンジェント
Public Function HArctan(x)
HArctan = Log((1 + x) / (1 - x)) / 2
End Function
'双曲線アークセカント
Public Function HArcsec(x)
HArcsec = Log((Sqr(-x * x + 1) + 1) / x)
End Function
'双曲線アークコセカント
Public Function HArccosec(x)
HArccosec = Log((Sgn(x) * Sqr(x * x + 1) + 1) / x)
End Function
'双曲線アークコタンジェント
Public Function HArccotan(x)
HArccotan = Log((x + 1) / (x - 1)) / 2
End Function
'対数
Public Function LogN(x)
LogN = Log(x) / Log(N)
End Function
（SoulMan） 2021/05/06(木) 22:41

 ありました。
どうもおかしいと思いました。(^^;
https://www.kanaya440.com/contents/script/vbs/function/num/exp2.html
（SoulMan） 2021/05/06(木) 23:35

 思わぬ多くの方のご回答、ありがとうございます！
 参考にさせていただきます。
 CAD的な機能、きっと多くの方が望んでいると思います。
 エクセルにそなえてほしい。

（図景） 2021/05/07(金) 06:00

 >エクセルにそなえてほしい。
 エクセルは表計算ソフトですからね．．．

 三角形の形を一意に決めるためには２角では不足です。
 他に辺の長さが必要です。
 さらに、位置や回転とかも含めるともうちょっと情報が必要です。

 挿入→図形→フリーフォームで 直線を一本引き、それを選択して実行してください。
 その直線を底辺とする三角形を描きます。
 角度は、45,45 のようにカンマ区切りで入力してください。　
 座標は下方向が正なのでそのようになります。

    Sub sample()
       Dim shp As Shape
       Dim Pa(1 To 2) As Double, Pb(1 To 2) As Double, Pc(1 To 2) As Double
       Dim anglA As Double, anglB As Double, anglC As Double
       Dim Lab As Double, Lbc As Double, Lca As Double, R As Double
       Dim v(1 To 2) As Double
       Dim pi As Double, buf
       pi = Atn(1) * 4

       If TypeName(Selection) <> "Drawing" Then
          MsgBox "フリーフォームで作成した直線を選択して実行してください", vbCritical
          Exit Sub
       End If
       Set shp = Selection.ShapeRange(1)

       Pa(1) = shp.Nodes(1).Points(1, 1)
       Pa(2) = shp.Nodes(1).Points(1, 2)
       Pb(1) = shp.Nodes(2).Points(1, 1)
       Pb(2) = shp.Nodes(2).Points(1, 2)

       v(1) = Pb(1) - Pa(1)
       v(2) = Pb(2) - Pa(2)
       Lab = Sqr(v(1) * v(1) + v(2) * v(2))
       v(1) = v(1) / Lab
       v(2) = v(2) / Lab

       buf = InputBox("2角の大きさをカンマ,区切りで入力してください")
       buf = Split(buf, ",")

       anglA = CDbl(buf(0))
       anglB = CDbl(buf(1))
       anglC = 180 - anglA - anglB

       R = Lab / Sin(pi / 180 * anglC) / 2
       Lbc = 2 * R * Sin(pi * anglA / 180)
       Lca = 2 * R * Sin(pi * anglB / 180)

       Pc(1) = Lca * Cos(pi * anglA / 180)
       Pc(2) = Lca * Sin(pi * anglA / 180)

       Pc(1) = Pc(1) * v(1) + Pc(2) * -v(2)
       Pc(2) = Pc(1) * v(2) + Pc(2) * v(1)

       Pc(1) = Pa(1) + Pc(1)
       Pc(2) = Pa(2) + Pc(2)

       With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Pa(1), Pa(2))
           .AddNodes msoSegmentLine, msoEditingCorner, Pb(1), Pb(2)
           .AddNodes msoSegmentLine, msoEditingCorner, Pc(1), Pc(2)
           .AddNodes msoSegmentLine, msoEditingCorner, Pa(1), Pa(2)
           .ConvertToShape
       End With

    End Sub
（´・ω・`） 2021/05/07(金) 08:04

 先ほどのマクロはちょっとバグがあるかも
（´・ω・`） 2021/05/07(金) 09:10

 こんばんは！
昨夜公式らしきものを提示したもののほんとかよ？と気になって書いてみました。。。
でも、All自動ではなくて「半自動」です。(^^;

 このコードを走らせると3本の線が出来ます。
出来た線を「手動で」移動させて三角形にしてください。(◎_◎;)

 つなぐコツは、最初に底辺をAltを押しながらセルの角に合わせて
次にその角に斜辺を合わせて
最後に残る1本を合わせると。。。完成。。です。(最後の１本が微妙に合わない(^^;）

 全部自動で出来るといいんですけどね。。。わちきの力では無理っぽいです。(真剣にやってないだけかもしれませんが(^^;）
取り敢えず、、3Stepで書けるので最初の案よりはましかと。。。
でも、、手動がいいと思いますよ。。。出来ないひがみかもしれませんけど。。。

 なお、何分にもずぶのど素人が片手間で書いたコードですのでお気に召さない箇所等は適当にアレンジしていただけますと幸甚です。
では、、、では、、、

 Option Explicit
Sub 一辺と二角から出来る三角形()
Dim Shap1 As Shape
Dim Shap2 As Shape
Dim Shap3 As Shape
Dim x1 As Variant
Dim x2 As Variant
Dim x3 As Single
Dim h1 As Variant
Dim h2 As Single
Dim h3 As Single
Dim F As Single
Dim bx As Single
Dim by As Single
Dim ex As Single
Dim ey As Single
ActiveSheet.DrawingObjects.Delete
Do
    h1 = Application.InputBox("底辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h1) = vbBoolean Then Exit Sub
Loop Until h1 > 0
Do
    x1 = Application.InputBox("左の角度を入力してくだい", Type:=1)
    If VarType(x1) = vbBoolean Then Exit Sub
Loop Until x1 > 0
Do
    x2 = Application.InputBox("右の角度を入力してくだい", Type:=1)
    If VarType(x2) = vbBoolean Then Exit Sub
Loop Until x2 > 0
With Range("E25") '書き出し位置
    bx = .Left
    by = .Top
    ex = .Left
    ey = .Top
End With
With Application
    x3 = 180 - x1 - x2
    F = h1 / Sin(.Radians(x3))
    h2 = .CentimetersToPoints(F * Sin(.Radians(x2)))
    h3 = .CentimetersToPoints(F * Sin(.Radians(x1)))
    h1 = .CentimetersToPoints(h1)
End With
'With Application
'    展開角度左 = 180 - 角度中心 - 角度右
'    F = 辺の長さ中心から右 / Sin(.Radians(展開角度左))
'    辺の長さ左から中心 = F * Sin(.Radians(角度右))
'    辺の長さ左から右 = F * Sin(.Radians(角度中心))
'End With
With ActiveSheet.Shapes
    Set Shap1 = .AddConnector(msoConnectorStraight, bx, by, ex + h1, ey)
    Set Shap2 = .AddConnector(msoConnectorStraight, bx, by, ex + h2, ey)
        Shap2.Rotation = -x1
    Set Shap3 = .AddConnector(msoConnectorStraight, bx, by, ex + h3, ey)
        Shap3.Rotation = x2
End With
Set Shap1 = Nothing
Set Shap2 = Nothing
Set Shap3 = Nothing
End Sub

 Option Explicit
Sub 二辺と一角から出来る三角形()
Dim Shap1 As Shape
Dim Shap2 As Shape
Dim Shap3 As Shape
Dim x1 As Variant
Dim x2 As Single
Dim x3 As Single
Dim h1 As Variant
Dim h2 As Variant
Dim h3 As Single
Dim F As Single
Dim bx As Single
Dim by As Single
Dim ex As Single
Dim ey As Single
ActiveSheet.DrawingObjects.Delete
Do
    h1 = Application.InputBox("底辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h1) = vbBoolean Then Exit Sub
Loop Until h1 > 0
Do
    h2 = Application.InputBox("辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h2) = vbBoolean Then Exit Sub
Loop Until h2 > 0
Do
    x1 = Application.InputBox("中心の角度を入力してくだい", Type:=1)
    If VarType(x1) = vbBoolean Then Exit Sub
Loop Until x1 > 0
With Range("E25") '書き出し位置
    bx = .Left
    by = .Top
    ex = .Left
    ey = .Top
End With
With Application
    h3 = Sqr(h1 ^ 2 + h2 ^ 2 - 2 * h1 * h2 * Cos(.Radians(x1)))
    F = h3 / Sin(.Radians(x1))
    x2 = .Degrees(Arcsin(h1 / F))
    x3 = .Degrees(Arcsin(h2 / F))
    h1 = .CentimetersToPoints(h1)
    h2 = .CentimetersToPoints(h2)
    h3 = .CentimetersToPoints(h3)
End With
'With Application
'    辺の長さ中心から右 = Sqr(辺の長さ左から中心 ^ 2 + 辺の長さ左から右 ^ 2 - 2 * 辺の長さ左から中心 * 辺の長さ左から右 * Cos(.Radians(角度左)))
'    F = 辺の長さ中心から右 / Sin(.Radians(角度左))
'    展開角度右 = .Degrees(Arcsin(辺の長さ左から中心 / F))
'    展開角度中心 = .Degrees(Arcsin(辺の長さ左から右 / F))
'End With
With ActiveSheet.Shapes
    Set Shap1 = .AddConnector(msoConnectorStraight, bx, by, ex + h1, ey)
    Set Shap2 = .AddConnector(msoConnectorStraight, bx, by, ex + h2, ey)
        Shap2.Rotation = -x1
    Set Shap3 = .AddConnector(msoConnectorStraight, bx, by, ex + h3, ey)
    If h1 > h2 Then
        Shap3.Rotation = x3
    Else
        Shap3.Rotation = 180 - (x1 + x2)
    End If
End With
Set Shap1 = Nothing
Set Shap2 = Nothing
Set Shap3 = Nothing
End Sub
'アークサイン
Public Function Arcsin(x As Double)
    Arcsin = Atn(x / Sqr(-x * x + 1))
End Function
すみません。書き出し位置を間違っていました。
1Step少なくなりました。m(__)m
ついでなので検証不足な気もしますが、
一辺と二角　
二辺と一角も書いてみました。
（SoulMan） 2021/05/07(金) 21:06

 （´・ω・`）　さん
 わざわざコード書いていただきありがとうございます。
 実行してみたのですが、フリーフォームで作成した直線を選択しても
 「フリーフォームで作成した直線を選択して実行してください」
 のメッセージが出ます。

  If TypeName(Selection) ～　をコメントアウトすると、すぐ下の
  Pa(1) = shp.Nodes(1).Points(1, 1)　の所で
 「指定したコレクションに対するインデックスが境界を越えています。」
 のメッセージが出ます…。

 SoulMan　さん
 わざわざコード書いていただきありがとうございます。
 > ついでなので検証不足な気もしますが
 OKでした。使わせていただきます。
（図景） 2021/05/08(土) 02:09

 フリーフォームで直線を引くんですよ。
 参考サイト
http://www4.synapse.ne.jp/yone/excel/excel_zu_freeform.html
（´・ω・`） 2021/05/08(土) 04:40

 おはようございます。

 （´・ω・`）さんのコードを試させて頂きました。
私のど素人コードより断然いいです。
ポイントは、フリーフォームの直線の描き方だと思います。

 始点をクリックしたら終点まで指を離すんですね？
ずーっとクリックしたままでは駄目で

 クリック→指を離して→終点でダブルクリック

 綺麗な三角形が描けました。素晴らしいです。

 図景　さんも是非試してみてください。。
 では、、では、、、検証Manでした。。。。
（SoulMan） 2021/05/08(土) 08:37

 一辺と二角　
二辺と一角とくれば、、
三辺。。。ですよねぇ(^^;
ありました。
作図の方は（´・ω・`）　さんのコードにお任せするとして、これ、家業の板金展開プログラムなんですねぇ
数値とか角度とか材料の発注時に必要だったんですね。
他にもいっぱいありました。。(ここからは有料になります←冗談です(笑)）
違うトピで紹介した材料の切り出しもこの流れなんですねぇ。。なんと17年前？？？
そりゃ記憶にないはずです。(^^;
ちょっと動かしてみましたけど、今回は作成できない場合があるみたいでエラー処理が必要のようです。
同業者の方で応用される方もいらっしゃるかもしれませんのでついでにUpしておきます。(おらんか？？？）
なお、何分にもずぶのど素人が片手間で書いたコードですのでお気に召さない箇所等は適当にアレンジしていただけますと幸甚です。、
では、、では、、

 Option Explicit
Sub 三辺から出来る三角形()
Dim Shap1 As Shape
Dim Shap2 As Shape
Dim Shap3 As Shape
Dim x1 As Single
Dim x2 As Single
Dim x3 As Single
Dim h1 As Variant
Dim h2 As Variant
Dim h3 As Variant
Dim F As Single
Dim bx As Single
Dim by As Single
Dim ex As Single
Dim ey As Single
On Error GoTo ErrorHandler
ActiveSheet.DrawingObjects.Delete
Do
    h1 = Application.InputBox("底辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h1) = vbBoolean Then Exit Sub
Loop Until h1 > 0
Do
    h2 = Application.InputBox("左辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h2) = vbBoolean Then Exit Sub
Loop Until h2 > 0
Do
    h3 = Application.InputBox("右辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h3) = vbBoolean Then Exit Sub
Loop Until h3 > 0
With Range("M40") '書き出し位置
    bx = .Left
    by = .Top
    ex = .Left
    ey = .Top
End With
With Application
    x1 = .Degrees(Arccos((h3 ^ 2 + h2 ^ 2 - h1 ^ 2) / 2 / h3 / h2))
    x2 = .Degrees(Arccos((h2 ^ 2 + h1 ^ 2 - h3 ^ 2) / 2 / h2 / h1))
    x3 = .Degrees(Arccos((h1 ^ 2 + h3 ^ 2 - h2 ^ 2) / 2 / h1 / h3))
    h1 = .CentimetersToPoints(h1)
    h2 = .CentimetersToPoints(h2)
    h3 = .CentimetersToPoints(h3)
End With
'With Application
'    展開角度中心 = .Degrees(Arccos((辺の長さ中心から右 ^ 2 + 辺の長さ左から中心 ^ 2 - 辺の長さ左から右 ^ 2) _
'                                    / 2 / 辺の長さ中心から右 / 辺の長さ左から中心))
'    展開角度左 = .Degrees(Arccos((辺の長さ左から中心 ^ 2 + 辺の長さ左から右 ^ 2 - 辺の長さ中心から右 ^ 2) _
'                                    / 2 / 辺の長さ左から中心 / 辺の長さ左から右))
'    展開角度右 = .Degrees(Arccos((辺の長さ左から右 ^ 2 + 辺の長さ中心から右 ^ 2 - 辺の長さ左から中心 ^ 2) _
'                                    / 2 / 辺の長さ左から右 / 辺の長さ中心から右))
'End With
With ActiveSheet.Shapes
    Set Shap1 = .AddConnector(msoConnectorStraight, bx, by, ex + h1, ey)
    Set Shap2 = .AddConnector(msoConnectorStraight, bx, by, ex + h2, ey)
        Shap2.Rotation = -x2
    Set Shap3 = .AddConnector(msoConnectorStraight, bx, by, ex + h3, ey)
    If h1 > h2 Then
        Shap3.Rotation = x3
    Else
        Shap3.Rotation = 180 - (x1 + x2)
    End If
End With
Set Shap1 = Nothing
Set Shap2 = Nothing
Set Shap3 = Nothing
Exit Sub
ErrorHandler:
Select Case Err.Number
    Case 0
        MsgBox "エラーは発生していません。", vbExclamation
    Case Else
        MsgBox "予測出来ないエラーが発生しました。" & vbCrLf & vbCrLf & _
        "Error　Number=" & Err.Number & vbCrLf & _
        "Error　Message=" & Err.Description, vbCritical
End Select
End Sub
'アークコサイン
Public Function Arccos(x As Double)
    Arccos = Atn(-x / Sqr(-x * x + 1)) + 2 * Atn(1)
End Function
（SoulMan） 2021/05/08(土) 11:37

 質問への回答から逸脱しているような気もしますが、面白かったので
 私も3辺の長さから三角形を描くマクロを作ってみました。

  3辺の長さ,Lab,Lbc,Lcaのとき
　頂点の座標を、頂点A(0,0),　頂点B(0,L1), 頂点C(x,y)とすると、
    x^2      + y^2 = Lca^2
   (x-Lab)^2 + y^2 = Lbc^2
  なので、片々引いて整理すると
   (x-Lab)^2 - x^2 = Lbc^2 - Lca^2
　 -2*x*Lab + Lab^2 = Lbc^2 - Lca^2

   x = ( Lab^2 + Lca^2 - Lbc^2 ) / 2
   y = sqr( Lca^2 - x^2 )

    Sub sample()

      l1 = 12
      l2 = 5
      l3 = 13

      drawTriangleby3sides l1, l2, l3

    End Sub

    Sub drawTriangleby3sides(l1, l2, l3)
      With ActiveCell
        x0 = .Left
        y0 = .Top + .Height
      End With

      l1 = Application.CentimetersToPoints(l1)
      l2 = Application.CentimetersToPoints(l2)
      l3 = Application.CentimetersToPoints(l3)

      x = (l1 ^ 2 + l2 ^ 2 - l3 ^ 2) / 2 / l1
      y = Sqr(l2 ^ 2 - x ^ 2)

      With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x0 + 0, y0 + 0)
          .AddNodes msoSegmentLine, msoEditingCorner, x0 + l1, y0
          .AddNodes msoSegmentLine, msoEditingCorner, x0 + x, y0 - y
          .AddNodes msoSegmentLine, msoEditingCorner, x0 + 0, y0 + 0
          .ConvertToShape
      End With

    End Sub
（´・ω・`） 2021/05/08(土) 13:24

 おぉぉっぉ、、これはいいですねぇ(^^;
学校らしくなってきましたねぇ
drawTriangleby3sides　に3辺を渡すだけで三角形になるのですね(^^;

 わちきのど素人コードにもすぐに組み込めますしね。。。
いやぁ、、勉強になりました。ありがとうございます。。。
（SoulMan） 2021/05/08(土) 17:13

 私の駄目駄目版を書き換えようとかと思いましたが、後々参考にされる方もいらっしゃるでしょうから。。。それはそれで残しておいて完成版を書いてみました。
drawTriangleby3sides　は、（´・ω・`）さんのをお借りしました。
随分とすっきりしました。
drawTriangleby3sides　は、一つでいいんですけど、、モジュールを分けましたので。。。
今回も、大変勉強になりました。ありがとうございました。m(__)m
では、、では、、

 Option Explicit
Sub 一辺と二角から出来る三角形完成版()
Dim x1 As Variant
Dim x2 As Variant
Dim x3 As Single
Dim h1 As Variant
Dim h2 As Single
Dim h3 As Single
Dim F As Single
ActiveSheet.DrawingObjects.Delete
Do
    h1 = Application.InputBox("底辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h1) = vbBoolean Then Exit Sub
Loop Until h1 > 0
Do
    x1 = Application.InputBox("左の角度を入力してくだい", Type:=1)
    If VarType(x1) = vbBoolean Then Exit Sub
Loop Until x1 > 0
Do
    x2 = Application.InputBox("右の角度を入力してくだい", Type:=1)
    If VarType(x2) = vbBoolean Then Exit Sub
Loop Until x2 > 0
With Application
    x3 = 180 - x1 - x2
    F = h1 / Sin(.Radians(x3))
    h2 = .CentimetersToPoints(F * Sin(.Radians(x2)))
    h3 = .CentimetersToPoints(F * Sin(.Radians(x1)))
    h1 = .CentimetersToPoints(h1)
End With
drawTriangleby3sides h1, h2, h3
End Sub
Sub drawTriangleby3sides(ByVal l1 As Single, ByVal l2 As Single, ByVal l3 As Single)
Dim x0 As Double
Dim y0 As Double
Dim x As Double
Dim y As Double
    With ActiveCell
        x0 = .Left
        y0 = .Top + .Height
    End With
    x = (l1 ^ 2 + l2 ^ 2 - l3 ^ 2) / 2 / l1
    y = Sqr(l2 ^ 2 - x ^ 2)
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x0 + 0, y0 + 0)
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + l1, y0
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + x, y0 - y
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + 0, y0 + 0
        .ConvertToShape
    End With
End Sub

 Option Explicit
Sub 二辺と一角から出来る三角形完成版()
Dim x1 As Variant
Dim x2 As Single
Dim x3 As Single
Dim h1 As Variant
Dim h2 As Variant
Dim h3 As Single
Dim F As Single
ActiveSheet.DrawingObjects.Delete
Do
    h1 = Application.InputBox("底辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h1) = vbBoolean Then Exit Sub
Loop Until h1 > 0
Do
    h2 = Application.InputBox("辺の長さをcm単位で入力してくだい", Type:=1)
    If VarType(h2) = vbBoolean Then Exit Sub
Loop Until h2 > 0
Do
    x1 = Application.InputBox("中心の角度を入力してくだい", Type:=1)
    If VarType(x1) = vbBoolean Then Exit Sub
Loop Until x1 > 0
With Application
    h3 = Sqr(h1 ^ 2 + h2 ^ 2 - 2 * h1 * h2 * Cos(.Radians(x1)))
    F = h3 / Sin(.Radians(x1))
    x2 = .Degrees(Arcsin(h1 / F))
    x3 = .Degrees(Arcsin(h2 / F))
    h1 = .CentimetersToPoints(h1)
    h2 = .CentimetersToPoints(h2)
    h3 = .CentimetersToPoints(h3)
End With
drawTriangleby3sides h1, h2, h3
End Sub
'アークサイン
Public Function Arcsin(x As Double)
    Arcsin = Atn(x / Sqr(-x * x + 1))
End Function
Sub drawTriangleby3sides(ByVal l1 As Single, ByVal l2 As Single, ByVal l3 As Single)
Dim x0 As Double
Dim y0 As Double
Dim x As Double
Dim y As Double
    With ActiveCell
        x0 = .Left
        y0 = .Top + .Height
    End With
    x = (l1 ^ 2 + l2 ^ 2 - l3 ^ 2) / 2 / l1
    y = Sqr(l2 ^ 2 - x ^ 2)
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x0 + 0, y0 + 0)
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + l1, y0
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + x, y0 - y
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + 0, y0 + 0
        .ConvertToShape
    End With
End Sub

 Option Explicit
Sub 三辺から出来る三角形完成版()
Dim x1 As Single
Dim x2 As Single
Dim x3 As Single
Dim h1 As Variant
Dim h2 As Variant
Dim h3 As Variant
Dim F As Single
ActiveSheet.DrawingObjects.Delete
Do
    Do
        h1 = Application.InputBox("底辺の長さをcm単位で入力してくだい", Type:=1)
        If VarType(h1) = vbBoolean Then Exit Sub
    Loop Until h1 > 0
    Do
        h2 = Application.InputBox("左辺の長さをcm単位で入力してくだい", Type:=1)
        If VarType(h2) = vbBoolean Then Exit Sub
    Loop Until h2 > 0
    Do
        h3 = Application.InputBox("右辺の長さをcm単位で入力してくだい", Type:=1)
        If VarType(h3) = vbBoolean Then Exit Sub
    Loop Until h3 > 0
    If (h2 + h3 <= h1) + (h1 + h3 <= h2) + (h1 + h2 <= h3) Then MsgBox "無効な値です。" & vbCrLf & "もう一度最初から入力してください。"
Loop Until (h2 + h3 > h1) * (h1 + h3 > h2) * (h1 + h2 > h3)
With Application
    h1 = .CentimetersToPoints(h1)
    h2 = .CentimetersToPoints(h2)
    h3 = .CentimetersToPoints(h3)
End With
drawTriangleby3sides h1, h2, h3
End Sub
Sub drawTriangleby3sides(ByVal l1 As Single, ByVal l2 As Single, ByVal l3 As Single)
Dim x0 As Double
Dim y0 As Double
Dim x As Double
Dim y As Double
    With ActiveCell
        x0 = .Left
        y0 = .Top + .Height
    End With
    x = (l1 ^ 2 + l2 ^ 2 - l3 ^ 2) / 2 / l1
    y = Sqr(l2 ^ 2 - x ^ 2)
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, x0 + 0, y0 + 0)
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + l1, y0
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + x, y0 - y
        .AddNodes msoSegmentLine, msoEditingCorner, x0 + 0, y0 + 0
        .ConvertToShape
    End With
End Sub
すみません。ついでに番外編で三辺もコレクションに追加しておいてください。
条件は、これであってると思うのですが？？？
すみません。間違っていました。m(__)m
（SoulMan） 2021/05/08(土) 19:08

 ありがとうございました！
 すべてのコードを一つのエクセルファイルにまとめ
 マクロボタンですぐ呼び出せるようにしました。
 今後活用させていただきます。

（図景） 2021/05/09(日) 06:13

コメント返信：

[ 一覧(最新更新順) ]

[[20210506063708]] 『角度を指定して作図できますか』（図景） ページの最後に飛ぶ

[[20210506063708]]　『角度を指定して作図できますか』（図景）　ページの最後に飛ぶ