[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『図形描画で台形作成』(空箱)
VBAで図形描画を使用し台形を作成したいと思ってます。
流れとして、
?@A1:幅入力、A2:高さ1入力、A3:高さ2入力
?Aコマンドボタンを押すと台形作成
たとえば最初に引くラインはどこのラインでも良いのですが、
最初に縦のラインを引くとして(始点固定)、
ActiveSheet.Shapes.AddLine(A, B(A2), C, D(A2)).Select
そのラインの座標を基に、横ラインを引いて
ActiveSheet.Shapes.AddLine(A, B(A1), C, D(A1)).Select
縦ライン引いて、
ActiveSheet.Shapes.AddLine(A(A1), B(A3), C(A1), D(A3)).Select
斜めラインを引いて
ActiveSheet.Shapes.AddLine(A(A2), B(A3), C(A2), D(A3)).Select
みたいな感じで、
最初に引いたラインの座標を基に、入力した数値の長さのラインを引いて
台形を作りたいです。(最後にグループ化します)
つまり、座標を取得する方法を教えて下さい。
< 使用 アプリ:Excel2000、使用 OS:WindowsXP >
台形の図形挿入ではだめなんですか?
↑ あぁ、上底も指定したいのですね。
(β) 2016/01/21(木) 19:11
AddLineで書いてみました。 以下コードでは上底の開始位置を F5の左上隅にしています。 開始位置、高さ、上底の長さ、下底の長さを、そちらの要件にあわせて調整願います。 コードは、各ラインをグループ化するところまでです。
Sub Sample() Dim w(1 To 4) As String Dim h As Double, topY As Double, btmY As Double Dim topBX As Double, topEX As Double, topW As Double Dim btmBX As Double, btmEX As Double, btmW As Double
h = 200 '高さ topW = 300 '上底の長さ btmW = 500 '下底の長さ
topBX = Range("F5").Left '上底の左端 topY = Range("F5").Top '上底の縦軸座標
btmY = topY + h topEX = topBX + topW btmBX = topBX + topW / 2 - btmW / 2 btmEX = btmBX + btmW
w(1) = ActiveSheet.Shapes.AddLine(topBX, topY, topEX, topY).Name '上底 w(2) = ActiveSheet.Shapes.AddLine(btmBX, btmY, btmEX, btmY).Name '下底 w(3) = ActiveSheet.Shapes.AddLine(topBX, topY, btmBX, btmY).Name '左辺 w(4) = ActiveSheet.Shapes.AddLine(topEX, topY, btmEX, btmY).Name '右辺
ActiveSheet.Shapes.Range(w).Group
End Sub
(β) 2016/01/21(木) 20:18
Dim w(1 To 4) As Variant (???) 2016/01/22(金) 09:02
>>Excel2000だと、グループ化のところでエラーになりますね。
あぁ、そうでしたか。検証ありがとうございます。
ところで、上底幅規定のため AddLine を使いましたが、本当は、台形挿入(AddShapeでmsoShapeTrapezoid)を使いたかったんです。 ただ、Adjustments.Item(1) の調整値、0 なら四角形、2 なら三角形になるわけですが、その間の調整値のルールを説明したページがみあたらず 断念しました。 調整値のルールがわかれば、台形挿入と調整、塗りつぶしなし といった簡単なコードで処理できると思うのですが。
★もっとも、xl2000 で台形挿入ができるかどうかは、環境がないので未確認です。
(β) 2016/01/22(金) 09:20
Excel2000では、台形挿入が無いみたいです。。。
(探したのですが、見つかりませんでした)
βさんに教えて頂いたコードで台形は上手く作図できました。
ありがとうございます。
少し形がイメージしてたのと違いましたが、
コードを少し変更すれば出来そうです。
入力:幅(底辺)、高さ(左辺)、高さ(右辺)
|\
|_|
(空箱) 2016/01/22(金) 10:33
Sub test() Dim h As Double, topY As Double Dim topBX As Double, topW As Double Dim btmBX As Double, btmW As Double
h = 200 '高さ topW = 300 '上底の長さ btmW = 500 '下底の長さ topBX = Range("F5").Left '上底の左端 topY = Range("F5").Top '上底の縦軸座標
ActiveSheet.Shapes.AddShape(msoShapeTrapezoid, topBX + (topW - btmW) / 2, topY, btmW, h).Select With Selection.ShapeRange .Adjustments.Item(1) = (btmW - topW) / btmW / 2 .Flip msoFlipVertical End With End Sub
しかし、欲しいのはどうやら竹を斜めにぶった切ったのような形の台形のようですね。
等辺ではないので、βさん案の線で描画でよさげです。
(???) 2016/01/22(金) 11:00
With Selection.ShapeRange .Adjustments.Item(1) = (btmW - topW) / btmW End With (???) 2016/01/22(金) 11:06
???さんありがとうございます。
あとで、試してみます!
(空箱) 2016/01/22(金) 16:33
|\
|_|
台形を作ろうと、
w(1) = ActiveSheet.Shapes.AddLine(topBX, topY, topEX, topY).Name '上底
w(2) = ActiveSheet.Shapes.AddLine(btmBX, btmY, btmEX, btmY).Name '下底
w(3) = ActiveSheet.Shapes.AddLine(topBX, topY, btmBX, btmY).Name '左辺
w(4) = ActiveSheet.Shapes.AddLine(topEX, topY, btmEX, btmY).Name '右辺
の変更を色々試してみましたがダメでした。。。
また、斜め線の長さをSqr関数で求めとようとしたのですが、
上手く使いこなすことすら出来ませんでした。
どなたかヒントでも頂ければと思います。
宜しくお願い致します。
(空箱) 2016/02/02(火) 16:14
同じように考えればいいのですがね。
提示の形、左上を a、左下を b、右下を c、右上を d とします。 この a,b,c,d の座標を取得しておいて a-->b,b-->c,c-->d,d-->a と線を引いていけばいいのですよ。
以下では a の場所を F10の左上隅、左側の高さが500、右側の高さが300、底辺の長さが 200 としています。
Sub Test() Dim aX As Double, aY As Double, bX As Double, bY As Double, cX As Double, cY As Double, dX As Double, dY As Double Dim w(1 To 4) As Variant
'position a aY = Range("F10").Top aX = Range("F10").Left
'position b
bY = aY + 500 '左側の高さ bX = aX
'position c
cY = bY cX = aX + 200 '底辺の長さ もちろん bX + 200 でもいいです。
'position d
dX = cX dY = cY - 300 '右側の高さ
w(1) = ActiveSheet.Shapes.AddLine(aX, aY, bX, bY).Name 'a->b w(2) = ActiveSheet.Shapes.AddLine(bX, bY, cX, cY).Name 'b->c w(3) = ActiveSheet.Shapes.AddLine(cX, cY, dX, dY).Name 'c->d w(4) = ActiveSheet.Shapes.AddLine(dX, dY, aX, aY).Name 'd->a
ActiveSheet.Shapes.Range(w).Group
End Sub
(β) 2016/02/02(火) 17:03
早速試してみましたが、バッチリ思い通りの台形が描けました!
ありがとうございます!!
値を変更するのは自分でやってみます!!
(空箱) 2016/02/02(火) 19:20
それとも最初の、
aY = Range("F10").Top
aX = Range("F10").Left
で、移動位置を決めるのでしょうか?
因みに、セルの中央にしたかったので、「.center」としてみたのですがダメでした。
(空箱) 2016/02/04(木) 17:16
? activesheet.shapes.Count
? activesheet.shapes(1).Name
? activesheet.shapes("Group 5").Name
? activesheet.shapes("Group 5").Left, activesheet.shapes("Group 5").Top
? activesheet.shapes(activesheet.shapes.Count).Left, activesheet.shapes(activesheet.shapes.Count).Top
または、等辺の台形のときに、特定のセルの座標を元に描画しましたが、同様にしてみてはどうでしょうか。
(???) 2016/02/04(木) 17:36
指定の場所というのが、どういうところを意図しているのか不明ですが、たとえば
ActiveSheet.Shapes.Range(w).Group
これを
With ActiveSheet.Shapes.Range(w).Group .Left = Range("H2").Left .Top = Range("H2").Top End With
こんなふうに書くと、グループ化された図形の左上隅が、H2の左上隅にあわせて配置されます。
(β) 2016/02/04(木) 17:48
指定出来るのかどうか謎ですが、
セルの端では無く、セルの中央に指定したいです。
セル幅が変わっても、中央になるように出来るでしょうか?
(空箱) 2016/02/04(木) 18:11
指定セルの中央ということなら
With ActiveSheet.Shapes.Range(w).Group .Left = Range("H2").Left + Range("H2").Width/ 2 .Top = Range("H2").Top + Range("H2").Height / 2 End With
このように。
(β) 2016/02/04(木) 20:18
↑ 台形の中央と指定セルの中央をあわせるということなら
With ActiveSheet.Shapes.Range(w).Group .Left = Range("K30").Left + Range("K30").Width / 2 - .Width / 2 .Top = Range("K30").Top + Range("K30").Height / 2 - .Height / 2 End With
といった感じで。
(β) 2016/02/04(木) 20:23
???さんありがとうございます!!
大変感謝です!!
(空箱) 2016/02/05(金) 08:05
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.