[[20160121162435]] 『図形描画で台形作成』(空箱) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『図形描画で台形作成』(空箱)

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


Excel2000だと、グループ化のところでエラーになりますね。
先頭の配列宣言を、以下に変えてみてください。

 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


いや、2000にも台形挿入はあるのですよ。
Excel2000で実験してみたところ、こんな感じでβさんと同じ図形を描けました。
台形挿入すると、必ず上辺が長くなるので、最後に上下反転してます。

 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


蛇足。
上の台形挿入コーディングをExcel2010で実行した場合、上下反転と、Item(1)の係数が違うので、以下のように変わります。
    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


グループ化された図形を指定の位置に動かすには、どうすればよいのでしょうか?
マクロの記録で、
  ActiveSheet.Shapes("Group 132").Select
  Selection.ShapeRange.IncrementLeft 34.5
  Selection.ShapeRange.IncrementTop 0.75
このコードを取得したのですが、
Group名(132)が毎回変わるので移動出来ません。
宜しくお願い致します。

それとも最初の、
  aY = Range("F10").Top
  aX = Range("F10").Left
で、移動位置を決めるのでしょうか?
因みに、セルの中央にしたかったので、「.center」としてみたのですがダメでした。

(空箱) 2016/02/04(木) 17:16


例えば、新規ブックでβさんのマクロを実行後、VBAの編集画面にあるイミディエイトウィンドウで、以下を1行ずつ実行してみてください。
最初に4本線を描くので、グループ化すると5番になるはず。何度か実行していれば、数字が変わってきますが。
最後にグループ化しているのだから、シェイプの最後にあるオブジェクトを対象にすれば良いですよね。

? 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.