突然すべての図形が消えた時!

中級VBA

はじめに

 図形(オートシェイプ)が、突然消えてしまう現象について1つの事案を紹介します。
図形が消える原因としては、Visibleプロパティが Flase に設定されている事が考えられますが、図形の移動などをVBAで行う際、エラーのために位置が全て0となってしまう事で消えたような状態になる事があります。

 今回はこれをプログラムで再現してみます。

図形を用意

 今回は以下のような状態で検証を行ってみます。

 オブジェクト名は以下のコードで確認しておきます。

Sub testObject1()
    Dim shp
    For Each shp In ActiveSheet.Shapes
        Debug.Print shp.Name
    Next
End Sub

 オブジェクト1オブジェクト2はそれぞれ、四角形:1四角形:2 という名前にしました。

エラーを起こして図形を消す

 以下のコードを実行すると、図形が全て消えてしまいます。

'エラーが出ずにオブジェクトが全て消えます。
Sub testObject2()
    Dim shapeName As String
    shapeName = ""
    With ActiveSheet.Shapes(shapeName)
        .Left = 100
        .Flip msoFlipHorizontal   'ここが原因!!
    End With
End Sub

図形の表示状態を確認する

 図形は消えていますが、最初のプログラム(testObject1)を実行するとオブジェクト名はきちんと表示されます。Excelメニューの「ホーム」>「編集」から「オブジェクトの編集と表示」を選択します。

 すると以下のような画面が表示されます。
これを見ますと、オブジェクト名の右側の目のようなマークがあります。この表示ですと図形は表示状態になります。

 ちなみに、正常な状態で四角形:1を非表示にした場合は、以下のようになります。

図形の位置を変更して表示させてみる

 上記の状態で図形が表示状態であることがわかったので、図形が見えていないのは表示位置がおかしな場所になっているのが原因と考えられます。そこで以下のプログラムで現在の図形の位置を確認してみる事にしましょう。

Sub testObject3()
    Dim shp
    For Each shp In ActiveSheet.Shapes
        Debug.Print shp.Name
        Debug.Print shp.Left
        Debug.Print shp.Top
        Debug.Print shp.Width
        Debug.Print shp.Height
    Next
End Sub

 結果は以下のようになりました。

四角形:1
 0 
 100 
 0 
 30 
 四角形:2
 0 
 50 
 0 
 30 

 この事から、Left と Width の値が 0 になってしまっているのがわかります。図形の位置を設定してやれば戻るはずなので、以下のプログラムで設定し直してみます。

Sub testObject4()
    Dim shp
    Dim i As Long
    i = 1
    For Each shp In ActiveSheet.Shapes
        shp.Left = 50
        shp.Top = 50 * i
        shp.Width = 150
        shp.Height = 30
        i = i + 1
    Next
End Sub

 無事に表示されました。

エラーの原因

 今回は、testObject2 のコードでは、エラーメッセージが出ずに突然オブジェクトが消えてしまう事態となりました。
 原因に関しては、ActiveSheet.Shapes(shapeName) の部分で図形の名前を適切に指定しなかったのが悪かったのでしょう。色々と検証しましたが、shapeName が空白の場合に上記の不具合が起こりました。

 shapeName が実際に無い図形の名前を指定した場合は、エラーメッセージが出るようです。

 このように図形を正しく指定しないと思わぬエラーを引き起こすの注意しましょう。
対策としては、事前に図形が存在するか確認した方が良いでしょう。

Sub testObject5()
    Dim shapeName As String
    shapeName = "四角形:1"
    
    If IsObject(ActiveSheet.Shapes(shapeName)) = False Or shapeName = "" Then
        MsgBox "オブジェクトが見つかりませんでした。"
        Exit Sub
    End If
    
    With ActiveSheet.Shapes(shapeName)
        .Left = 100
        .Flip msoFlipHorizontal
    End With
End Sub

 上のコードでは、図形オブジェクトが存在するかを確認しています。また、図形オブジェクト名が空白の場合もチェックしています。なぜか図形オブジェクト名が空白の場合は、通り抜けてしまうためです。

 成功すると以下のように、上の図形が移動します。(Flipは意味なかったか、、、)
今回はエラーを引き起こした原因は Flip メソッドでした。

コメント

タイトルとURLをコピーしました