【Excel/VBA】ワークシート内の全シェイプのテキストを新規シートのA列に書き出す

この間作ったのの逆というか。

この間作ったやつで作った資料のシェイプのテキストを元に、一覧表を作りたくなって作りました。

シェイプにテキストオブジェクト（？）が、あるかどうかをチェックするプロパティがない、だと…？！
仕方ないので、レジュームで回避してます。On Errorが三個あるのがポイント。
めんどうくさいので、それ以外のエラーもResume Next（←

'------------------------------------------------------------------------------
Public Sub morning2013_10_8(tgtWS As Worksheet)
'====================================
' 指定したワークシートの全シェイプを収集し、新しいシートにテキストを書き出す
'
' テキストの無いシェイプは、Err.Number=13を返すので、
' 該当シェイプ名を一列ずらして入力し、レジュームする
'====================================
Dim WS As Worksheet
Dim shps As Shapes, shp As Shape
Dim i As Long

On Error GoTo Err_morning2013_10_8

ThisWorkbook.Sheets.Add before:=ThisWorkbook.Worksheets(1)
Set WS = ActiveSheet

Set shps = tgtWS.Shapes

On Error GoTo Non_Err_CK

i = 0
For Each shp In shps
i = i + 1
WS.Cells(i, 1).Value = shp.TextFrame.Characters.Caption
Next

On Error GoTo Err_morning2013_10_8

If i = 0 Then WS.Cells(1, 1).Value = "シェイプ情報を取得できませんでした。"

Set shp = Nothing
Set shps = Nothing
Set WS = Nothing

Exit Sub
Non_Err_CK:
Select Case Err.Number
Case 13
WS.Cells(i, 2).Value = shp.Name & " (" & TypeName(shp) & ")"
Resume Next
End Select

Err_morning2013_10_8:
Debug.Print Err.Number & " " & Err.Description
i = i - 1
Resume Next

End Sub
'------------------------------------------------------------------------------