[[20100611164632]]　『シェイプへのテキスト入力』（みっと）　ページの最後に飛ぶ

『シェイプへのテキスト入力』（みっと）

 1個の図とテキストのシェイプが９個あり、これがグループ化されています。

 グループが解除されている状態で、たまたまShapes("Rectangle 41")　41から９個なら
 このコードで文字が入ります。

 ・グループ化されていると.Select　が良くないみたいですが、どうすれば良いかわかりません。
 ・たまたま41からであり、この値を取得する方法がわかりません。

 グループをクリックすると、この処理を実行したいのですが、可能でしょうか？
 'オートシェイプテキスト編集
 Sub os_tedit()
     Dim t_data(3, 3) As String
     Dim i As Integer
     Dim j As Integer
     Dim kk As Integer

     t_data(1, 1) = "test1"
     t_data(1, 2) = "test2"
     t_data(1, 3) = "test3"

     t_data(2, 1) = "test11"
     t_data(2, 2) = "test12"
     t_data(2, 3) = "test13"

     t_data(3, 1) = "test21"
     t_data(3, 2) = "test22"
     t_data(3, 3) = "test23"

     For i = 1 To 3
         For j = 1 To 3

         ActiveSheet.Shapes("Rectangle " & (41 + kk)).Select
         Selection.Characters.Text = t_data(i, j)

         kk = kk + 1
         Next j
     Next i
 End Sub

 Sendkeysを使えば、グループ化解除しなくてもテキストの挿入が出来ますが（Excel2002で確認）、
 グループ化解除-----テキスト設定-----再度グループ化という手順がよいと思いますが・・・・。

 新規ブックにて、試してみてください。
 標準モジュール(Module1)に

 '================================================================================
 Option Explicit
 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
    shpnm = Application.Caller
    Set shp = ActiveSheet.Shapes(shpnm).ParentGroup
    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
    cnt = shp.GroupItems.Count - 1
    shp.Ungroup
    For g0 = 1 To cnt
       With ActiveSheet.Shapes("Rectangle " & m_num + g0 - 1)
          .TextFrame.Characters.Text = "test" & 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

 別の標準モジュール（Module2）にサンプルデータ作成コードとして、

 '===========================================================================
 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

 Mk_Sampleを実行してみてください。

 アクティブシートに　スマイルと９個の四角形（Rectangle）が作成され、これらがグループ化されたものが
 作成されます。

 作成されたグループ化された図形をクリックしてください。
 四角形にTextToShape内で指定された文字列が設定されます。

 グループ化している図形の条件は、

 四角形は、Rectangle ｎ（nは数字）という名前で作成され、nという数字は、連続していること。
 四角形以外の図形が一つ含まれていること

 です。作成したグループ化した図形に上述のTextToShapeを登録する。

 Mk_Sampleは、この条件に合った図形の一例です。

 Excel2002で動作確認しました。

 ichinose

 ichinoseさんありがとうございました。
 すごいです。内容は難しいですが、マクロを登録するだけでそのまま動きました。
 感謝致します。
 （みっと）

コメント返信：

[ 一覧(最新更新順) ]

[[20100611164632]] 『シェイプへのテキスト入力』（みっと） ページの最後に飛ぶ

[[20100611164632]]　『シェイプへのテキスト入力』（みっと）　ページの最後に飛ぶ