[[20091229141336]]　『オートシェイプ』（taka）　ページの最後に飛ぶ

『オートシェイプ』（taka）

ネットで検索し、丸の中に "積" を入れました。

この丸が楕円形なので、"積"に合った丸い円にするには、どうすればいいですか？

それと円と、"積"をクリアしたいのですが、マクロの記録では、

以下のように出来たのですが、クリア出来ませんでした。

合わせて、宜しくお願い致します。

Sub クリア()

    Selection.ClearContents
End Sub

Sub オートシェイプ()

  Dim c As Range
  If Not TypeName(Selection) = "Range" Then Exit Sub
  For Each c In Selection
    With c.MergeArea
      If c.Address = .Item(1).Address Then
        ActiveSheet.Shapes.AddShape(msoShapeOval, .Left, .Top, _
        .Width, .Height).Fill.Visible = False
        .Characters.Text = "積"             ' オートシェイプの中に文字
        .Characters.Font.Size = 10              ' フォントサイズを10ポイントに
        .HorizontalAlignment = xlHAlignCenter   ' 中央揃え
        .VerticalAlignment = xlVAlignCenter     ' 中央揃え
      End If
    End With
  Next
End Sub

Excel2000　WindowsXP

 '===============================================================
 Sub オートシェイプ()
    Dim vl As Double
    Dim vt As Double
    Dim vw As Double
    Dim vh As Double
    Dim c As Range
    If TypeName(Selection) = "Range" Then
       Set c = Selection
       If c.Width > c.Height Then
          vl = c.left + c.Width / 2 - c.Height / 2
          vt = c.Top
          vw = c.Height
          vh = c.Height
       Else
          vl = c.left
          vt = c.Top + c.Height / 2 - c.Width / 2
          vw = c.Width
          vh = c.Width
       End If
       With ActiveSheet.Ovals.Add(vl, vt, vw, vh)
          .Text = "積"
          .Font.Size = 10            ' フォントサイズを10ポイントに
          .HorizontalAlignment = xlHAlignCenter   ' 中央揃え
          .VerticalAlignment = xlVAlignCenter     ' 中央揃え
       End With
    End If
 End Sub
 '==================================================================
 Sub クリア()
    If TypeName(Selection) = "Oval" Then
       Selection.Delete
    End If
 End Sub

 これで試してみてください。

 選択したセル範囲に作成できる最大の円を作成し、図形のテキストとして「積」という文字を表示します。
 (セル範囲の幅や高さが小さいと円の中の「積」という文字が表示しきれない場合があります）

 クリアというプロシジャーは、アクティブシートにある選択されている円を削除します。

 ichinose

ichinoseさん回答有り難うございます。

丸の中の"積"が、右にあって、のぎへんの一部しか見えません。

真ん中に出来ないでしょうか？

クリアは、エラーは、無いのですが、丸も文字も消えてくれません。

宜しくお願い致します。(taka)

 >丸の中の"積"が、右にあって、のぎへんの一部しか見えません。 
 コードは、選択したセル範囲に納まるように円を作成しています。
 選択セル範囲の幅や高さが小さいとこのような現象になります。

 回避方法としては、

 1　選択セルの幅又は、高さを大きくする

 2　.Font.Size = 10   を　6ぐらいにする

 3　Autoisizeプロパティを使う

 '===============================================================
 Sub オートシェイプ()
    Dim vl As Double
    Dim vt As Double
    Dim vw As Double
    Dim vh As Double
    Dim c As Range
    If TypeName(Selection) = "Range" Then
       Set c = Selection
       If c.Width > c.Height Then
          vl = c.Left + c.Width / 2 - c.Height / 2
          vt = c.Top
          vw = c.Height
          vh = c.Height
       Else
          vl = c.Left
          vt = c.Top + c.Height / 2 - c.Width / 2
          vw = c.Width
          vh = c.Width
       End If
       With ActiveSheet.Ovals.Add(vl, vt, vw, vh)
          .Text = "積"
          .Font.Size = 8          ' フォントサイズを10ポイントに
          .HorizontalAlignment = xlHAlignCenter   ' 中央揃え
          .VerticalAlignment = xlVAlignCenter     ' 中央揃え
          .AutoSize = True
       End With
    End If
 End Sub

 このどれかで対応してください。

 >クリアは、エラーは、無いのですが、丸も文字も消えてくれません。

 その円を選択して実行しなければ消えませんよ！！
 選択しなくて消したいなら

 Sub クリア()
    activesheet.ovals.delete
 End Sub

 これでいけそうですけど、アクティブシートに存在する円が全部削除されます。
 仕様の記述があいまいなので、本当はどうしたいのかがはっきりわかりません。

 ichinose

 もう一つの代替案　テキストボックスと円の二つの図形を描き、グループ化する方法

 '===============================================================
 Sub オートシェイプ()
    Dim vl As Double
    Dim vt As Double
    Dim vw As Double
    Dim vh As Double
    Dim c As Range
    Dim r As Shape
    Dim t As Shape
    If TypeName(Selection) = "Range" Then
       Set c = Selection
       If c.Width > c.Height Then
          vl = c.Left + c.Width / 2 - c.Height / 2
          vt = c.Top
          vw = c.Height
          vh = c.Height
       Else
          vl = c.Left
          vt = c.Top + c.Height / 2 - c.Width / 2
          vw = c.Width
          vh = c.Width
       End If
       Set r = ActiveSheet.Shapes.AddShape(msoShapeOval, vl, vt, vw, vh)
       r.Line.Visible = True
       Set t = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, vl, vt, vw, vh)
       With t
          With .TextFrame
             With .Characters
                .Text = "積"
                .Font.Size = 10
             End With
             .AutoMargins = False
             .MarginLeft = 0
             .MarginTop = 0
             .MarginBottom = 0
             .MarginRight = 0
             .HorizontalAlignment = xlCenter
             .VerticalAlignment = xlCenter
          End With
          .Fill.Visible = msoFalse
          .Line.Visible = False
       End With
       ActiveSheet.Shapes.Range(Array(t.Name, r.Name)).Group
    End If
 End Sub
 '==================================================================
 Sub クリア()
     ActiveSheet.GroupObjects.Delete
 End Sub

 作成される図形のタイプを変えたので、クリアの仕方も変わってきます。

 試してみてください。

 ichinose@午後から正月準備の買い物だって←時間のかかる買い物大っ嫌い
 訂正---2009/12/30　11：57

 更に訂正　----　2009/12/30 18:12
 もう一度訂正--  2009/12/30 18:25

ichinoseさん代替案のほうで、思いどおりに出来たので、感激しております。

＞作成される図形のタイプを変えたので、クリアの仕方も変わってきます。

　ActiveCellの丸と積を消したいのですが、どうすればよいでしょうか？

　何度も申し訳ありませんが、宜しくお願い致します。(taka)

 >ActiveCellの丸と積を消したいのですが

 だったら、これで試してみてください。

 '==================================================================
 Sub クリア()
     Dim gpo As GroupObject
     For Each gpo In ActiveSheet.GroupObjects
        If Not Application.Intersect(ActiveCell, Range(gpo.TopLeftCell, gpo.BottomRightCell)) Is Nothing Then
           gpo.Delete
        End If
     Next
 End Sub

 ichinose

ichinoseさん今まで手作業でやっていたので、仕事が楽になります。

本当に有り難うございました。taka

コメント返信：

[ 一覧(最新更新順) ]

[[20091229141336]] 『オートシェイプ』（taka） ページの最後に飛ぶ

[[20091229141336]]　『オートシェイプ』（taka）　ページの最後に飛ぶ