[[20090417160332]]　『セル内にオートシェイプをフィットさせる』（どら）　ページの最後に飛ぶ

『セル内にオートシェイプをフィットさせる』（どら）

 セル内に接する円のオートシェイプを描くのをここで先日教えて
 頂きましたが、Picture 16のオートシェイプを、この円の変わりに
 フィットさせたいのですが、お願い致します｡
 日にちもたって、内容も変わってしまったので、新しくアップしました。

 下は、セル内に接する円のもので、
 ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, _
            rng.Width, rng.Height).Select
 の部分を変えるのでしょうが、わかりませんのでお願い致します｡

 Sub test()
 Dim sp As Shape, flg As Boolean
 Dim obj As Object, rng As Range
 Set rng = Application.InputBox(Prompt:="○を入れるセルを選択して下さい", Type:=8)
 If Not rng Is Nothing Then
     flg = False
     For Each sp In ActiveSheet.Shapes
         If sp.TopLeftCell.Address(0, 0) = "A1" Then
             flg = True
             sp.Delete
             Exit For
         End If
     Next
     If Not flg Then
         ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, _
             rng.Width, rng.Height).Select
         With Selection.ShapeRange
             .Fill.Visible = msoFalse
             .Line.Weight = 0.5
             .ZOrder msoSendToBack
         End With
         rng.Select
         Set rng = Nothing
     End If
 End If
 End Sub

 Picture 16というShapeオブジェクトは、既にアクティブシートに存在しているという事ですね？

 Sub test()
 Dim sp As Shape, flg As Boolean
 Dim obj As Object, rng As Range
 Const spnm = "Picture 16"
 Set rng = Application.InputBox(Prompt:="○を入れるセルを選択して下さい", Type:=8)
 If Not rng Is Nothing Then
     flg = False
     For Each sp In ActiveSheet.Shapes
         If sp.TopLeftCell.Address(0, 0) = "A1" Then
             flg = True
             sp.Delete
             Exit For
         End If
     Next
     '↑この辺りのコードの必要性の有無は仕様が分かりませんのでそのまま残しておきました。

     If Not flg Then
         With ActiveSheet.Shapes(spnm)
             .Left = rng.Left
             .Top = rng.Top
             .Width = rng.Width
             .Height = rng.Height
             .Fill.Visible = msoFalse
             .Line.Weight = 0.5
             .ZOrder msoSendToBack
         End With
         rng.Select
         Set rng = Nothing
     End If
 End If
 End Sub

 ichinose

高さ方向にフィットして、幅方向はその比率に応じて変化する様です。』（どら）

 幅方向もフィットさせたいのですが可能でしょうか。
 それと、セル結合されたセルにもフィットさせたいのですが。
 わがまま言ってすみません。
 1).Width = rng.Width
 2).Height = rng.Height

 1)2)を逆にすると、幅にフィットして、高さ方向は、その比率変化する様ですが
 意味が分かりません。

     If Not flg Then
         With ActiveSheet.Shapes(spnm)
             .LockAspectRatio = msoFalse  'これを追加して試してみて！！
             .Left = rng.Left
             .Top = rng.Top
             .Width = rng.Width
             .Height = rng.Height
             .Fill.Visible = msoFalse
             .Line.Weight = 0.5
             .ZOrder msoSendToBack
         End With
         rng.Select
         Set rng = Nothing
     End If

 ichinose

ichinoseさんフィットしました。複数セルを選択してもOKでした。

 結合セルのみ頭のセルにフィットしますが、使い方で複数セルに
 対応で十分です。どうもありがとうございました。 （どら）

貼り付ける際の事でまた教えて下さい。（どら）

 シェイプを他の新しいシートに作成してマクロを実行する前のシートを
 Application.InputBoxで選択するとrng.Selectでrangeクラスのselect
 メゾットが失敗しましたとエラーしますが、どの様に対処すれば良いですか？

 Sub test()
     Dim sp As Shape, flg As Boolean
     Dim obj As Object, rng As Range
     '新しいシートにシェイプを作成する
     Sheets.Add
     Range("B1") = "テスト用シェイプ"
     Range("B1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
     ActiveSheet.Paste

     Const spnm = "Picture 1"
     Set rng = Application.InputBox(Prompt:="シェイプを入れるセルを選択して下さい", Type:=8)
     If Not rng Is Nothing Then
         If Not flg Then
             With ActiveSheet.Shapes(spnm)
                 .LockAspectRatio = msoFalse
                 .Left = rng.Left
                 .Top = rng.Top
                 .Width = rng.Width
                 .Height = rng.Height
                 .Fill.Visible = msoFalse
                 .Line.Weight = 0.5
                 .ZOrder msoSendToBack
             End With
             rng.Select
             Set rng = Nothing
         End If
     End If
 End Sub

 >rng.Selectでrangeクラスのselectメゾットが失敗しましたとエラーしますが
 別シートのセルを選択する場合は、親オブジェクトから、順に選択しなければエラーになってしまいます。

 例1

 現在アクティブなシ-トがSheet1の時にSheet2のセルＡ１を選択したい場合、
 worksheets("sheet2").activate
 range("a1").select

 例2

 現在アクティブなシ-トがBOOK1のSheet1の時にBook2のSheet2のセルＡ１を選択したい場合、
 workbooks("book2").activate
 worksheets("sheet2").activate
 range("a1").select

 よって、今回のrngの場合、
 With rng
     .Parent.Parent.Activate
     .Parent.Activate
     .Select
 End With

 なんてすると、正常に作動します。

 が、面倒ですね

 Application.Goto rng

 このようにすると、1行で解決します。

 これで投稿されたエラーは解決しますが、果して正常に作動しますか？

 これ「テスト用シェイプ」と書かれた図形を
 指定されたセル範囲(違うシートや違うブックの場合もある）に移す　という仕様ですよね？
 もしそうだとしたら、シートが違うセル範囲を選択すると今のままでは、正常に作動しませんよ！！

 以下のようにして試してみてください。

 '========================================================================
 Sub test()
     Dim sp As Shape, flg As Boolean
     Dim obj As Object, rng As Range
     '新しいシートにシェイプを作成する
     ActiveSheet.Select
     Sheets.Add
     Range("B1") = "テスト用シェイプ"
     Range("B1").CopyPicture Appearance:=xlScreen, Format:=xlPicture
     ActiveSheet.Paste
     With ActiveSheet
        Set sp = .Shapes(.Shapes.Count)
     End With
     Const spnm = "Picture 1"
     Set rng = Application.InputBox(Prompt:="シェイプを入れるセルを選択して下さい", Type:=8)
     If Not rng Is Nothing Then
         If Not flg Then  '←このflgの意味はわからないので残しておきました
            If Not rng.Parent Is ActiveSheet Then
               sp.Copy
               Application.Goto rng
               ActiveSheet.Paste
               sp.Delete '元の図形を削除
               With ActiveSheet
                  Set sp = .Shapes(.Shapes.Count)
               End With
            End If
            With sp
               .LockAspectRatio = msoFalse
               .Left = rng.Left
               .Top = rng.Top
               .Width = rng.Width
               .Height = rng.Height
               .Fill.Visible = msoFalse
               .Line.Weight = 0.5
               .ZOrder msoSendToBack
            End With
            Set rng = Nothing
         End If
     End If
 End Sub

 試してみてください。

 直前の投稿は、非常にわかりやすく記述された投稿だと思います。
 (新規ブックで簡単に再現できるコードの提示、エラー箇所とエラー内容の記述）

 が、投稿されたコードが本来どのような動作をするプログラムなのか？
 つまり、仕様になる記述も コードの提示と並んで記述しなければなりませんよ！！

 ichinose

張り付きました。ichinoseさんありがとうございます。（どら）

 Parentの説明大変すみません。
 仕様の記述ですが、やりたいことが曖昧ですが、概略を書くべきですね。
 複数セルに文字を入力してその位置関係を、オートシェイプにして
 希望のセルにフィット貼付したいと言う感じなのですが。
 オートシェイプを作るところがはっきりしていないのですが、
 複数セルでのオートシェイプ作成と貼付が確認出来ましたので、
 今回の物で実現出来ます。大変お世話になります。

コメント返信：

[ 一覧(最新更新順) ]

[[20090417160332]] 『セル内にオートシェイプをフィットさせる』（どら） ページの最後に飛ぶ

[[20090417160332]]　『セル内にオートシェイプをフィットさせる』（どら）　ページの最後に飛ぶ