[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『シェイプをコピーしたものが動作しない。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
ここで質問者さんは、「複写した後で一度ファイルを閉じて開きなおす」という方法でエラー回避を行う 手段を選択されたみたいなので、図形に登録するプログラム内でエラーを回避する方法です。
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を実行してください。
スマイルと9個の四角形がグループ化された図形を作成します。この図形には、TextToShapeプロシジャーが 登録されています。
クリックすると、テキストの入力を促されます。テキストを入力すると、9つの四角形に同じテキストが反映されるという簡単な仕様です。これだとコピーした図形にもエラーにならず作動します。
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)で親オブジェクトを取得しています。 取得したオブジェクトは、一度グループ化を解除し、再度グループ化を行っています。 (実は、同じことを下の方で行っていますが、旧バージョンとの互換性や新しいバージョンに対応した時 のために敢えて解除・再グループ化を2度する処理を残しておきます)。
以上です。
(ichinose) 2015/04/15(水) 05:39
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.