EXCEL VBA で自在に図形を変化させたい(2)

質問

前回，質問させてもらい、非常に役に立つ回答をもらい解決しました。

今回、いろいろ本を見ても解決できない問題がありましたので再度質問をします。

EXCEL上にコマンドボタンを一つ配置します。右クリック→プロパティ→オブジェクト名をCmd作図に変更しておきます。
デザインモードでボタンをダブルクリックしてVBEでコード表示にします。

Private Sub Cmd作図_Click()
ActiveSheet.Shapes.AddLine 200, 200, 400, 400
End Sub

これでEXCEL上のコマンドボタンを押すと直線が作図できます。
次にAddLine以下の数字を変えて再度実行しますと別の直線がかけるのですが最初の直線が残ったままですので重なったりします。

前回、回答では

Private Sub Cmd作図_Click()

With ActiveSheet
For Each Sh In .Shapes
Sh.Delete
Next Sh
ActiveSheet.Shapes.AddLine 200, 200, 400, 400

End With

End Sub

という回答をもらっています。こうすれば前回描いた線を消してから作図できます。

しかし、前回は「マクロの実行」ボタンからの作図でしたので問題にはならなかったのですが、今回、EXCEL上にコマンドボタンを配置したところ、コマンドボタンもShapesと認識してしまうらしく、線と一緒に消されてしまいます。
この問題を解決できるコードを教えてもらいたいのですが。

よろしくお願いします。

回答No.6

imogasi · ベストアンサー

#5です。消すだけならＰｕｂｌｉｃを使って凌ぎました。
x,y,zは勝手な値を入れました。
Public a, b, c, d As String
Private Sub CommandButton1_Click()
Dim x As Single, y As Single, z As Single, Sh As Shape

On Error Resume Next
x = 100
y = 50
z = 200
With ActiveSheet
a = .Shapes.AddLine(200, 200, 200, 200 - x).Name
b = .Shapes.AddLine(200, 200 - x, 200 + y, 200 - x - y * (z / 10)).Name
c = .Shapes.AddLine(200 + y, 200 - x - y * (z / 10), 200 + y, 200).Name
d = .Shapes.AddLine(200 + y, 200, 200, 200).Name
End With

End Sub

Private Sub CommandButton2_Click()
If a = "" Then
Exit Sub
Else
With ActiveSheet
.Shapes(a).Delete
.Shapes(b).Delete
.Shapes(c).Delete
.Shapes(d).Delete
a = "": b = "": c = "": d = ""
End With
End If
End Sub

お礼

何度も回答ありがとうございます。

早速，試してみました。

EXCEL上のコマンドボタンを消さずに見事に図形を消すことが出来ます。

ただ、一点、気になるのが最初にEXCELを開き描画した後、必ず削除ボタン（CommandButton２のことです）で消してから描画しないと前の描画が消えなくなってしまうことです。

メッセージボックスなどで警告すればいいのかなと思っています。

しかし、これで一件落着です。

ありがとうございました。

回答No.5

imogasi

＃２です。補足に関して。
a,b,c,dｍは
Private Sub Cmd描画_Click()
End Sub
の中で使えるが、そこを抜けて
別のモジュール
Private Sub Cmd削除_Click()
End Sub
では、何の意味もなく、使えないのではないですか。
取りあえず。
引数で渡せるかどうか。
また蛇足ですが、この辺の数の型はＬｏｎｇが多いようですからマニュアルを見てください。

回答No.4

taocat

こんにちは。

＞多分、コマンドボタン以外（英語のEXCEPTのような）は消します。という条件文が必要なのではないかと思うのですが

それが、
If sh.name <> "Cmd作図" then これですよ。(^^;;;

それはそうとして、おかしいですねぇ。
当方回答する時は一応動作確認の上で回答しているんですが。
それに最初の質問ではユーザーフォームもないし描画コマンドないし・・・・。(^^;;;

で、再度ユーザーフォーム、描画用コマンドボタン等同じ条件でテストしてみましたが、ちゃんと動作します。

考えられることは、シート上のコマンドボタンのオブジェクト名（Cmd作図)が、IF文で比較している名前と微妙に違うのではありませんか。

If sh.name <> "Cmd作図" のように、"Cmd作図" となってますか？

ーーーーーーーーーーーーーーーーーーーーーーーーー

Private Sub Cmd描画_Click()
Dim x As Single, y As Single, z As Single, Sh As Shape
On Error Resume Next
x = CSng(Text立ち上がり.Value)
y = CSng(Text幅.Value)
z = CSng(Text勾配.Value)
With ActiveSheet
For Each Sh In .Shapes

If Sh.Name <> "Cmd作図" Then
Sh.Delete
End If

Next Sh
.Shapes.AddLine 200, 200, 200, 200 - x
.Shapes.AddLine 200, 200 - x, 200 + y, 200 - x - y * (z / 10)
.Shapes.AddLine 200 + y, 200 - x - y * (z / 10), 200 + y, 200
.Shapes.AddLine 200 + y, 200, 200, 200
End With

End Sub

ーーーーーーーーーーーーーーーーーーーー
以上です。

お礼

何度も回答ありがとうございました。

昨日より暇を見てはトライしているのですがだめでした。
しかし、コードにつきましてはたいへん勉強させていただきました。（今も勉強中です。　笑）

このコードが利用できればimogasiさんの回答と合わせて2つの有効なコードがわかったことになります。

この場を借りてお礼申し上げます。

補足

再度、回答ありがとうございます。

いろいろ試したのですがやはり消えてしまいます。

EXCEL上にコマンドボタンを貼り付けダブルクリックでコードに

UserForm1.Show

オブジェクト名ははCmd作図に直してあります。

Cmd作図ボタンを押すとUserForm1がEXCEL上に現れ、立ち上がり、幅、勾配をそれぞれ20,90,5と入力して描画ボタンを押すと図形は作図されます。

そして前に描いてあった図形も消えています。

ここまでは予定どおりなのですがCmd作図ボタンもDeleteされてしまいます。

う～ん、何かが違うのですかね。

ひょっとしてコードのウィンドウがUseForm１（描画ボタンのコードが書かれている）とSheet１（作図ボタンのコードが書かれている）の２つ別々だからですかね。

回答No.3

taocat

おはようございます。
シートに図形を貼り付けるとなかなかですよねぇ。(^^;;;

コマンドボタンCmd作図を消したくなければ

Private Sub Cmd作図_Click()
With ActiveSheet
　For Each Sh In .Shapes

　　If sh.Name <> "Cmd作図" Then
　　　　sh.Delete
　　End If

　Next Sh
　ActiveSheet.Shapes.AddLine 200, 200, 400, 400
End With
End Sub

それから、シートに四角、円等など色んな図形を描きそれがどんな名前になっているか調べて、今回のようにその名前を利用すると簡単便利になりますよ。
調べるには例えば下記のようなコード。

Sub Test()
　Dim Shp As Object
　For Each Shp In ActiveSheet.Shapes
　　MsgBox Shp.Name
　Next Shp
End Sub

以上です。

補足

回答ありがとうございます。

試してみたのですが残念ながらコマンドボタンが消えてしまいます。

多分、コマンドボタン以外（英語のEXCEPTのような）は消します。という条件文が必要なのではないかと思うのですが。

回答No.2

imogasi

下記を参考に考えてください。
Sub test02()
For i = 1 To 5
x = ActiveSheet.Shapes.AddLine(100 + i * 50, 100, 100 + i * 50, 200).Name
MsgBox "次へ"
ActiveSheet.Shapes(x).Delete
Next i
End Sub
移りが早いと確認がしにくいのでＭｓｇＢｏｘを途中に入れてます。
縦棒が右に動くように見えるのが確認できます。
その前の直線は消えています。
ＡｄｄとＮａｍｅが同時に出来てしまうこと
Ｎａｍｅで指定したいＳｈａｐｅｓの特定が出来てしまうこと
がミソです。

補足

回答ありがとうございます。

良いヒントと感じましたの応用してみました。

1番の方の補足の欄に記入しましたUserForm１に削除ボタンを追加しました。

描画ボタンで作図後、別の図面を描くときは削除ボタンで消します。

削除ボタン無しで古い図形が自動的に削除出来ればよかったのですが...。

プログラムは以下の通りです。

Private Sub Cmd描画_Click()

Dim x As Single, y As Single, z As Single, Sh As Shape

On Error Resume Next
x = CSng(Text立ち上がり.Value)
y = CSng(Text幅.Value)
z = CSng(Text勾配.Value)

With ActiveSheet
a = .Shapes.AddLine(200, 200, 200, 200 - x).Name
b = .Shapes.AddLine(200, 200 - x, 200 + y, 200 - x - y * (z / 10)).Name
c = .Shapes.AddLine(200 + y, 200 - x - y * (z / 10), 200 + y, 200).Name
d = .Shapes.AddLine(200 + y, 200, 200, 200).Name
End With

End Sub

Private Sub Cmd削除_Click()

With ActiveSheet
.Shapes(a).Delete
.Shapes(b).Delete
.Shapes(c).Delete
.Shapes(d).Delete
End With

End Sub

残念ながらエラーになります。

.Shapes(a).Delete

のところでデバックします。

回答No.1

hogehage

For Each Sh In .Shapes

を

For Each Sh In .Lines

とすれば、削除対象はラインだけになります。

補足

回答ありがとうございます。

質問の内容では確かに出来ました。

しかし、以下のプログラムだと元の線が消えません。

Private Sub Cmd作図_Click()
UserForm1.Show
End Sub

Private Sub Cmd描画_Click()
Dim x As Single, y As Single, z As Single, Sh As Shape
On Error Resume Next
x = CSng(Text立ち上がり.Value)
y = CSng(Text幅.Value)
z = CSng(Text勾配.Value)
With ActiveSheet
For Each Sh In .Lines
Sh.Delete
Next Sh
.Shapes.AddLine 200, 200, 200, 200 - x
.Shapes.AddLine 200, 200 - x, 200 + y, 200 - x - y * (z / 10)
.Shapes.AddLine 200 + y, 200 - x - y * (z / 10), 200 + y, 200
.Shapes.AddLine 200 + y, 200, 200, 200
End With
End Sub

UserForm1には「立ち上がり」、「幅」、「勾配」のテキストボックスとCmd描画のコマンドボタンが配置されています。