[[20150410130248]]　『シェイプをコピーしたものが動作しない。Applicat』（setcom）　ページの最後に飛ぶ

『シェイプをコピーしたものが動作しない。Application.Caller』（setcom）

グループ化されたシェイプがあり、これをクリックすると、 Sub TextToShape()が動作して
処理されるのですが。

このシェイプを、他のシートにコピーしてクリックすると、
実行時のエラー'1004'
指定された値は、境界を超えています。
とエラーして、Set shp = ActiveSheet.Shapes(shpnm).ParentGroup
でエラーしています。
shpnm = Application.Callerが、問題なのだろうと、
Application.Callerを調べようとしましたが、理解出来ません。
どこがいけないのか教えて頂けるでしょうか。

 Sub TextToShape()
    Dim shpnm As String
    Dim cshp As Shape
    Dim p_nm As String
    Dim m_num As Long
    Dim shp As Shape
    Dim g0 As Long
    Dim cnt As Long
    Dim nn As Integer
    shpnm = Application.Caller
    Set shp = ActiveSheet.Shapes(shpnm).ParentGroup
    With shp
       m_num = 0
       For Each cshp In .GroupItems
       nn = nn + 1
          If cshp.Type = msoAutoShape Then
             If cshp.AutoShapeType = msoShapeRectangle Then
                If m_num = 0 Then
                   m_num = CLng(Replace(cshp.Name, "Rectangle", ""))
                Else
                   m_num = Application.Min(m_num, CLng(Replace(cshp.Name, "Rectangle", "")))
                End If
             Else
                p_nm = cshp.Name
             End If
          Else
             p_nm = cshp.Name
          End If
       Next
    End With
    cnt = shp.GroupItems.Count - 1
    shp.Ungroup
     For g0 = 1 To cnt
        With ActiveSheet.Shapes("Rectangle " & m_num + g0 - 1)
          OS_T(g0) = .TextFrame.Characters.Text  
       End With
    Next
        test.Show
    For g0 = 1 To cnt
       With ActiveSheet.Shapes("Rectangle " & m_num + g0 - 1)
          .TextFrame.Characters.Text = OS_T(g0) 
       End With
    Next
    ReDim nmarray(1 To cnt + 1)
    For g0 = 1 To cnt
       nmarray(g0) = "Rectangle " & m_num + g0 - 1
    Next
    nmarray(cnt + 1) = p_nm
    ActiveSheet.Shapes.Range(nmarray()).Group
  End Sub

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

試してみました。
コピーした図形をグループ解除し、再度グループ化するとエラーはでませんでした。

（マナ） 2015/04/11(土) 09:23

検索したら、同じ事例がありました。（最後のほう）

 ＞とりあえずの回避策としては、複写した後で一度ファイルを閉じて開きなおすか、一度グループを解除して再度グループ化しなおすことで治りました。

 https://social.msdn.microsoft.com/Forums/en-US/0be9c0cd-69d9-4815-abe6-5cb0ba890dfa?forum=vbajp

 質問と関係ありませんが、参考にしたコードはこちらですか。
[[20100611164632]]　
Excel2013であれば、グループ化したまま図形のテキストを編集できました。

（マナ） 2015/04/11(土) 14:12

 コピーしたら、グループ化された情報が壊れている　完全なバグですね！！
 コピーされたグループ化図形をクリックすると、

 Set shp = ActiveSheet.Shapes(shpnm).ParentGroup

 ここでエラーになる。ここでは、子の図形から親の図形を取得しています。

 このエラートラップを　On Error Resume Nextで　拾ってしまい、

 別の方法で　親オブジェクトを取得すれば良いですよね！！
 同時に「コピーした図形をグループ解除し、再度グループ化する」を行ってしまえば、次回からは、
 通常処理で親オブジェクトが取得できることになります。

 では、別の方法とは？

 まず、対象シートから　グループ化されたShapeオブジェクトを探します(Typeプロパティを参照する）。

 グループ化されたShapeオブジェクトが見つかったら、
 GroupItemsプロパティで子図形群が取得できますから、その中に　ActiveSheet.Shapes(shpnm).Nameと同じ図形があれば、
 このグループ化されたShapeオブジェクトが取得するオブジェクトです。

 ここで注意するのは、shpnmで検索するのではなく、ActiveSheet.Shapes(shpnm).Nameで検索することです。

（ichinose） 2015/04/12(日) 07:09

皆さん大変有り難う御座いました。
マクロコードは理解出来て無いので、一度保存で再読み出しとしてみます。

（setcom） 2015/04/13(月) 10:46

[[20150413111027]]

 ここで質問者さんは、「複写した後で一度ファイルを閉じて開きなおす」という方法でエラー回避を行う
 手段を選択されたみたいなので、図形に登録するプログラム内でエラーを回避する方法です。

 setcomさんが提示されたコードは、このままでは作動しませんよね（ユーザーフォームを呼び出していますからね）！！

 こういう質問の場合、閲覧者を問題の箇所まで導く記述をするべきですよ！！

 新規ブックにて

 標準モジュール（Module1）に

 '===========================================================================
 Option Explicit
 Sub Mk_Sample()
    Dim g0 As Long
    Dim r As Range
    Dim nmarray(9) As Variant
    Set r = Range("b5:c10")
    With ActiveSheet.Shapes.AddShape(msoShapeSmileyFace, r.Left, r.Top, r.Width, r.Height)
       nmarray(0) = .Name
    End With
    Set r = Range("d5:e5")
    For g0 = 0 To 8
       Set r = Range("d5:e5").Offset(g0 \ 3, (g0 Mod 3) * 2)
       With ActiveSheet.Shapes.AddShape(msoShapeRectangle, r.Left, r.Top, r.Width, r.Height)
          nmarray(g0 + 1) = .Name
       End With
    Next
    With ActiveSheet.Shapes.Range(nmarray()).Group
       .OnAction = "TextToShape"
    End With
    ActiveCell.Activate
 End Sub
 '======================================================================================　
 Sub TextToShape()
    Dim shpnm As String
    Dim cshp As Shape
    Dim p_nm As String
    Dim m_num As Long
    Dim shp As Shape
    Dim g0 As Long
    Dim cnt As Long
    Dim gitms() As Variant
    Dim mes As Variant
    shpnm = Application.Caller
    On Error Resume Next
    Set shp = ActiveSheet.Shapes(shpnm).ParentGroup
    If Err.Number <> 0 Then
       If find_Pshp(ActiveSheet.Shapes(shpnm).Name, ActiveSheet, shp, gitms()) = 0 Then
          shp.Ungroup
          Set shp = ActiveSheet.Shapes.Range(gitms()).Regroup
       Else
          Stop
       End If
    End If
    On Error GoTo 0
    With shp
       m_num = 0
       For Each cshp In .GroupItems
          If cshp.Type = msoAutoShape Then
             If cshp.AutoShapeType = msoShapeRectangle Then
                If m_num = 0 Then
                   m_num = CLng(Replace(cshp.Name, "Rectangle", ""))
                Else
                   m_num = Application.Min(m_num, CLng(Replace(cshp.Name, "Rectangle", "")))
                End If
             Else
                p_nm = cshp.Name
             End If
          Else
             p_nm = cshp.Name
          End If
       Next
    End With
    mes = Application.InputBox("テキストを入力して下さい", , , , , , , 2)
    If TypeName(mes) <> "Boolean" Then
       cnt = shp.GroupItems.Count - 1
       shp.Ungroup
       For g0 = 1 To cnt
          With ActiveSheet.Shapes("Rectangle " & m_num + g0 - 1)
             .TextFrame.Characters.Text = mes
             .TextFrame.Characters.Font.Size = 8
          End With
       Next
       ReDim nmarray(1 To cnt + 1)
       For g0 = 1 To cnt
          nmarray(g0) = "Rectangle " & m_num + g0 - 1
       Next
       nmarray(cnt + 1) = p_nm
       ActiveSheet.Shapes.Range(nmarray()).Regroup
    End If
 End Sub
 '================================================================================================
 Function find_Pshp(ByVal shpnm As String, ByVal wsh As Object, shp As Shape, gitmnm() As Variant) As Long
    '指定された子図形名の親図形を取得する　同時にその親図形のすべての子図形群の配列を返す
    'input  shpnm  検索する子図形名　　wsh　検索するシート
    'output Find_Pshp 0　親オブジェクト検索成功　1　検索失敗　　　Shp　親図形　　gitmnm()　子図形名の配列（配列は呼び出し側で用意する）
    Dim shp1 As Shape
    Dim shp2 As Shape
    Dim cnt As Long
    find_Pshp = 1
    For Each shp1 In wsh.Shapes
       If shp1.Type = msoGroup Then
          cnt = 0
          For Each shp2 In shp1.GroupItems
             ReDim Preserve gitmnm(1 To cnt + 1)
             gitmnm(cnt + 1) = shp2.Name
             cnt = cnt + 1
             If UCase(shp2.Name) = UCase(shpnm) Then
                Set shp = shp1
                find_Pshp = 0
             End If
          Next
       End If
    Next
 End Function

 以上です。

 まず、Mk_Sampleを実行してください。

 スマイルと９個の四角形がグループ化された図形を作成します。この図形には、TextToShapeプロシジャーが
 登録されています。

 クリックすると、テキストの入力を促されます。テキストを入力すると、９つの四角形に同じテキストが反映されるという簡単な仕様です。これだとコピーした図形にもエラーにならず作動します。

    On Error Resume Next
    Set shp = ActiveSheet.Shapes(shpnm).ParentGroup
    If Err.Number <> 0 Then
       If find_Pshp(ActiveSheet.Shapes(shpnm).Name, ActiveSheet, shp, gitms()) = 0 Then
          shp.Ungroup
          Set shp = ActiveSheet.Shapes.Range(gitms()).Regroup
       Else
          Stop
       End If
    End If

 という箇所でエラーを検知し、別の方法（find_Pshp）で親オブジェクトを取得しています。
 取得したオブジェクトは、一度グループ化を解除し、再度グループ化を行っています。
 （実は、同じことを下の方で行っていますが、旧バージョンとの互換性や新しいバージョンに対応した時
 のために敢えて解除・再グループ化を２度する処理を残しておきます）。

 以上です。

（ichinose） 2015/04/15(水) 05:39

コメント返信：

[ 一覧(最新更新順) ]

[[20150410130248]] 『シェイプをコピーしたものが動作しない。Applicat』（setcom） ページの最後に飛ぶ

[[20150410130248]]　『シェイプをコピーしたものが動作しない。Applicat』（setcom）　ページの最後に飛ぶ