エクセルVBAでAutoShape削除

質問

シートからオートシェープの星型と線を削除するためのマクロですが、以下でうまく行きます。

Sub SAKUJO()
For Each s In ActiveSheet.Shapes
If s.Type = msoLine Or s.AutoShapeType = msoShape5pointStar Then s.Delete
Next
End Sub

質問は、線と星型を他のオートシェープと選別するために、線は「Type」、星型は「AutoShapeType」と異なる選別方法を別々に指定しなければならないのかということです。そもそも「Type」と「AutoShapeType」は何が違うのでしょう？
両方を同じように「Type」か「AutoShapeType」あるいは他の方法で指定する方法はないのでしょうか？

回答No.5

KenKen_SP · ベストアンサー

こんにちは。KenKen_SP です。

補足というより、蛇足コメントです、、、

Wendy02 さんご提示の通り、Name で識別するのが最も手っ取り
早そうですね。

一意の名前についてですが、このような場合次の方法がいいと思
います。

シェープをコードで書いた時点で既に Excel が一意の名前を付与
しています。後で処理し易くするために、その名前に接頭辞か
接尾辞を加えます。

With ActiveSheet.Shapes.AddShape _
　　(msoShape5pointStar, LP, TP, W, H)
　　.Name = "5pointStar_" & .Name
End With

この方法ですと、同名は発生しません。

これを再処理する場合は Shapes コレクションか DrawingObjects
コレクションでループさせて Name プロパティの値を Like 演算子
で比較するか、InStr 関数を使います。

Like 演算子による方法は既に Wendy02 さんが示されてますので、
InStr 関数による方法です。

For Each shp In ActiveSheet.DrawingObjects
　　If InStr(1, shp.Name, "5pointStar_") > 0 Then
　　　　shp.Delete
　　End If
Next shp

ご参考までに。

お礼

いつもお世話様です。

>　.Name = "5pointStar_" & .Name

すばらしい！
これなら連番の振り方でなやむ必要がなくなりました。
ありがとうございます。

回答No.6

Wendy02

merlionXX さん、KenKen_SP さん、こんにちは、Wendy02 です。

回答とは直接関係がありませんが、私は、自分のこの関連コードに関しては、未だ、解明できていないところがあります。解決せずに、ちょうど1年になろうとしています。

merlionXXさんは、お分かりになっていると思いますが、いわゆる、オートシェイプを量産して、削除してということを繰り返していくうちに、いわゆる、.name の「オブジェクト・ネーム」の枝番が、更新もされずに、インクリメンタルに増えていきますね。

その点で、私は、自分でオートシェイプを使ったコードに対して不安を覚えました。

仕事で毎日、私の作ったシートとコードで、オートシェイプの生成と削除を繰り返したら、年間では、1万では済まないはずで、通常使用で、最低1年間ぐらいのブックの安全が確保されるか、分からなくなりました。そこで、全面的にコードの内容を換えたことがあります。

それに比べて、シート名の枝番は、再起動すれば、更新されますね。また、自動記録マクロのMacro名も更新されます。開いたまま、Add-Deleteを繰り返さなければ、ほぼ大丈夫です。ですが、オートシェイプだけは出来ません。

削除して、再起動すれば、本当に、全部がクリアになっているならよいのですが、このように、何かが残っているとなると、果たして、Add-Delete を繰り返して、大丈夫かなっていうのが、私の懸案の問題です。

だから、オートシェイプは、使いまわし出来るなら、使いまわししていこう、というのが、現在の私のVBAにおいての考え方です。

まだ、解決には至っていません。

分かっているのは、 \ApplicationData\Microsoft\Office\Recent フォルダの .lnk ファイルには、それは存在していません。レジストリだとしたら、それも、まずいはずです。

#4 の'オートシェイプを作る
のコードは、現れないようなことはありませんよね。ところが、繰り返しをすると、図形が現れなくなります。そこで、コードの最後に、Application.ScreenUpdating = True はいれないといけないのですが、何かがヘンだなって思います。

私のPC固有の現象かもしれませんが、他の方が、そうしたコードで図形が出ないといわれたことがありますので、それは間違いないと思っています。

お礼

補足に書いた件、新しい質問としてみます。

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

補足

KenKen_SP さん、Wendy02 さん、おふたりには本当にいつもお世話になります。

> name の「オブジェクト・ネーム」の枝番が、更新もされずに、インクリメンタルに増えていきますね。

はい、じつはこれは次の質問にしようと思っていたんです。
どこまでも増えていくけど、大丈夫なんですか？って。

テスト用のコードも作ってあります。
現在、28000番まできていますが、いまのところ大丈夫です。

For n = 1 To 100　の数値を増やして、いっぺんに何万もやってみようかとも思いましたが、１０００を超えると、極端に動きがおそくなり、やがて固まってしまいます。

Sub test()

With Application
.WindowState = xlMaximized
.DisplayFormulaBar = False
.Caption = "☆TEST中☆"
End With

With ActiveWindow
.WindowState = xlMaximized
.DisplayWorkbookTabs = False
.DisplayGridlines = False
.DisplayHeadings = False
End With

For Each myCB In Application.CommandBars
myCB.Enabled = False
Next myCB

Randomize

With ActiveSheet
.Cells.Interior.ColorIndex = 1

CL = Int((50 * Rnd) + 1)
L1 = Int((700 * Rnd) + 20)
H1 = Int((450 * Rnd) + 20)

Set SA = .Shapes.AddShape(msoShape5pointStar, L1, H1, 25, 25)
SA.Name = "Merlion_" & SA.Name
SA.Fill.ForeColor.SchemeColor = CL

For n = 1 To 100

CL = Int((50 * Rnd) + 1)
L2 = Int((650 * Rnd) + 20)
H2 = Int((450 * Rnd) + 20)

On Error GoTo line

SA.Top = H2 - SA.Width / 2
SA.Left = L2 - SA.Height / 2
SA.Fill.ForeColor.SchemeColor = CL

Set SL = .Shapes.AddLine(L1, H1, L2, H2)
SL.Name = "Merlion_" & SL.Name
Application.StatusBar = SL.Name

SL.line.Weight = 0.75
SL.line.ForeColor.SchemeColor = CL

L1 = L2
H1 = H2

Next

SA.ZOrder msoBringToFront
SA.line.Visible = True
SA.line.ForeColor.SchemeColor = CL

For i = 1 To 800 Step 60
SA.Rotation = i / 10
SA.line.Weight = i
DoEvents
Next

line:

For Each s In .Shapes
If s.Name Like "Merlion_*" Then s.Delete
Next

.Cells.Interior.ColorIndex = xlNone

End With

With Application
.DisplayFullScreen = False
.DisplayFormulaBar = True
.DisplayStatusBar = True
.Caption = ""
End With

With ActiveWindow
.DisplayWorkbookTabs = True
.DisplayGridlines = True
.DisplayHeadings = True
End With

For Each myCB In Application.CommandBars
myCB.Enabled = True
Next myCB

End Sub

回答No.4

Wendy02

merlionXX さん、こんにちは。
一応、サンプルは提示しておきます。

#　星は、Regtangle

Sub ShapesTypeName()
Dim shp As Object
For Each shp In ActiveSheet.DrawingObjects
　　MsgBox TypeName(shp)
Next
End Sub

＞一回の操作で何百個も図形が生成され、削除されるんです。だからいちいち一意の名前なんて付けられないんです。

'オートシェイプを作る
Sub AddshapePrc()
With ActiveCell
　　Lf = .Left: Tp = .Top: Ht = .Height
　　FirstLocation = 0.5 + Ht * 2
　　For i = 0 To 10
　　　With ActiveSheet.Shapes.AddShape _
　　　　(msoShapeOval, FirstLocation + Lf, Ht * i + Tp, Ht, Ht)
　　　　.Line.ForeColor.SchemeColor = 10
　　　　.Visible = True
　　　　.Name = "Ov" & i + 1　　'ここの部分
　　　End With
　　Next
　End With
End Sub

'削除方法
Sub DelshapePrc()
For Each shp In ActiveSheet.Shapes
　　If shp.Name Like "Ov*" Then
　　　 shp.Delete
　　End If
Next
End Sub

お礼

お礼がおそくなり、すみません。

なるほど～っ！！
.Name = "Ov" & i + 1　　ですかあ。
これならいくつでも名前が付けられますね。

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

回答No.3

Wendy02

merlionXXさん、こんにちは。

すみません。あまり、私は、星などは、使ったことがなかったので、出来ると思い込んでいました。先ほど、TypeName でもとってみたのですが、星は、Rectangle でした。

そうすると、既存のものに対しては、AutoShapeType の組み込み定数以外にはなさそうですね。

逆にいうと、私の実際のコードでは、先に、オートシェイプを作る際に、オートシェイプの名前に一意の名前をつけています。そうすれば、見失うことがありませんから。

お礼

> オートシェイプの名前に一意の名前をつけています。

ありがとうございます。
でもうごきの激しいのを作っているので、一回の操作で何百個も図形が生成され、削除されるんです。だからいちいち一意の名前なんて付けられないんです。

補足

何度もありがとうございます。
そうですよね、ふつうVBAで星型なんて使いませんよね（笑）

TypeNameでとる?
Cells(n, "G").Value = TypeName(S)とやってみたら、すべて「Shape」でしたが、どうやって取得したのでしょうか？

> 星は、Rectangle

ええっ？！Rectangleって四角形って意味ですよ？！

回答No.2

Wendy02

こんにちは。

＞そもそも「Type」と「AutoShapeType」は何が違うのでしょう？
＞両方を同じように「Type」か「AutoShapeType」あるいは他の方法で指定する方法はないのでしょうか？

私の経歴はそんなに長くないのですが、AutoShape自体が、時代を経て、コレクション化したのではないでしょうか？

Type で取れる「MsoShapeType」クラスのというのは、AutoShape、Chart、Comment、OLEObject, FormControl などに、Lineもあって、もともと別な存在だったわけです。

それを統合して、AutoShape にしたのであって、上記のAutoShape の個別のAutoShape コレクションは、図形のひとまとめにしたもので、その中に、AutoShapeType があります。

別の方法といっても、DrawingObjectのShapeRange　では、同じように、TypeとAutoShapeType とになるので、同じことです。だから、おなじ プロパティで選別する方法は、プロパティの　name をLike で取る以外は、ないのではないかと思います。name は、Object名として、マクロ以外には変更は出来ませんから、ある程度は、有効だ思います。

お礼

Wendy02さん、いつもお世話様です。
くだらない質問ですみません。

補足

Nameで区別できればいいと思い、以下のマクロでNameを取得してみました。

Sub s_name()
n = 5
For Each s In ActiveSheet.Shapes
n = n + 1
Cells(n, "D").Value = s.Name
Cells(n, "E").Value = s.Type
Cells(n, "F").Value = s.AutoShapeType
Next
End Sub

ところが、これでは線は「Line ###」、ワードアートは「WordArt ###」、フォームからの挿入のものは「Check Box ###」、「Option Button ###」と区別できるのですが、図形は星型も月型もハート型もみな「AutoShape ###」で区別がつかないんです。（四角形は「Rectangle ###」、円弧は「Arc ###」、楕円は「Oval "###」で区別できたのですが、それ以外はみな「AutoShape ###」です。）

回答No.1

moooon

しらべてみたら、線のAutoShapeTypeは－２でした。
星は９２でした。
だから、こうやったら両方とも削除できました。

For Each s In .Shapes
Select Case s.AutoShapeType
Case 92, -2
s.Delete
End Select
Next

お礼

ありがとうございます。
これはいい！と思って試したら、星と線だけではなく、ワードアートやフォームから入れたボタンやチェックボックス等も削除されてしまいました。
フォームから挿入したものもAutoShapeTypeは-2のようです。