Excelノート 17-1 図形

HOME  検索  索引  もくじ  関数目次ージへ        次ページへ

タイトル欄のアドレスは、エクセルファンクラブの該当する頁へのリンク先です。
詳しい事は、こちらの
お願いをご覧になってください。

1  オートシェイプで作った図形や線などをセル範囲で指定して削除するには?
2  Shapeオブジェクトをシートの所定の位置に移動するには?
3  任意のセルの位置をポイントで表示するには? 
4  選択したセルに、オートシェイプの○を書くには
5  セルの中に、オートシェイプの矢印を書く
6  セルの中に波線を書くには
7  鉄道を現すような、白黒線を書くには
8  太さや幅を指定できる二重線
9  シート内の全ての図形を削除するには
10 アクティブになっているグラフやテキストなどのオブジェクト名を取得するには
11 図形を指定のセルに移動
12 複数の図形を選択し、それぞれの名前、位置などを知るには
13 図形の位置を取得するには
14 図形の削除各種
15 図形のサイズを、セルに入力したミリの数値で変更するには
16 図形をアニメーションのように回転、移動、拡大するには?
17 図形を選択した時、色を変更するには
18 横並び、縦並びの3つの○を書くには?
19 図形描画で半円を描くには?
20 選択範囲に一回り小さい四角形を描くには?

1 オートシェイプで作った図形や線などをセル範囲で指定して削除するには?
B10からE20の中に収まっている図形を削除します。
Sub test()
  Dim wLeft As Long
  Dim wTop  As Long
  Dim wRight As Long
  Dim wBottom As Long
  Dim s As Object
  With Range("B10:E20")
    wTop = .Top
    wLeft = .Left
    wBottom = .Top + .Height
    wRight = .Left + .Width
  End With
  For Each s In ActiveSheet.DrawingObjects
    With s
      If wTop <= .Top And _
         wLeft <= .Left And _
         wBottom >= .Top + .Height And _
         wRight >= .Left + .Width Then
        .Delete
      End If
    End With
  Next
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
2 Shapeオブジェクトをシートの所定の位置に移動するには?
Excel2002確認済み
Sub test()
  With ActiveSheet.Shapes(1)
    .Top = Range("E5").Top
    .Left = Range("E5").Left
  End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
3 任意のセルの位置をポイントで表示するには?
Range("B2").Left   'セルB2 の左位置
Range("B2").Top
   'セルB2 の上位置
4 選択したセルに、オートシェイプの○を書くには
http://www.keep-on.com/~excelyou/2000lng1/200006/00060069.txt
  「しるしを付けるには」  【編集ラウンジ】
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
      End If
    End With
  Next
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub 選択されたセルに大きくまん丸に書く()
  Dim X As Double
  Dim Y As Double
  Dim L As Double
  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
        L = IIf(.Width > .Height, .Height, .Width)
        X = .Left + (.Width - L) / 2
        Y = .Top + (.Height - L) / 2
        ActiveSheet.Shapes.AddShape(msoShapeOval, X, Y, L, L).Fill.Visible = False
      End If
    End With
  Next
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
選択したセルの中に等間隔に3つの丸を書きます
Sub 等間隔に3つの丸を書く()
 Dim X(1 To 3) As Double
 Dim Y As Double
 Dim L As Double
 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
    L = Application.WorksheetFunction.Min(.Height, .Width / 3)
    X(1) = .Left - L / 2 + (.Width / 6)
    X(2) = .Left - L / 2 + (.Width / 2)
    X(3) = .Left - L / 2 + (.Width / 6 * 5)
    Y = .Top + (.Height - L) / 2
    With ActiveSheet.Shapes
     .AddShape(msoShapeOval, X(1), Y, L, L).Fill.Visible = False '左
     .AddShape(msoShapeOval, X(2), Y, L, L).Fill.Visible = False '中央
     .AddShape(msoShapeOval, X(3), Y, L, L).Fill.Visible = False '右
    End With
   End If
  End With
 Next
End Sub
Sub 等間隔に小さな3つの丸を書く()
 Dim X(1 To 3) As Double
 Dim Y As Double
 Dim L As Double
 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
    L = Application.WorksheetFunction.Min(.Height, .Width / 3) / 2
    X(1) = .Left - L / 2 + (.Width / 6)
    X(2) = .Left - L / 2 + (.Width / 2)
    X(3) = .Left - L / 2 + (.Width / 6 * 5)
    Y = .Top + (.Height - L) / 2
    With ActiveSheet.Shapes
     .AddShape(msoShapeOval, X(1), Y, L, L).Fill.Visible = False '左
     .AddShape(msoShapeOval, X(2), Y, L, L).Fill.Visible = False '中央
     .AddShape(msoShapeOval, X(3), Y, L, L).Fill.Visible = False '右
    End With
   End If
  End With
 Next
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
5 セルの中に、オートシェイプの矢印を書く
http://www.keep-on.com/~excelyou/2000lng4/200006/00060163.txt
  「オートシェイプで矢印を書くには」  【VBAラウンジ】
→以外の矢印の時は、msoShapeRightArrow の部分をを、
↑ の時は 
msoShapeUpArrow
← の時は 
msoShapeLeftArrow
↓ の時は 
msoShapeDownArrow
に変更します。

 Sub セル中央に縦横同サイズの→を書く()
  Dim X As Double, Y As Double, L As Double, 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
    L = IIf(.Width > .Height, .Height, .Width)
    X = .Left + (.Width - L / 2) / 2
    Y = .Top + (.Height - L / 2) / 2
    ActiveSheet.Shapes.AddShape(msoShapeRightArrow, X, Y, L / 2, L / 2).Fill.Visible = False
    End If
   End With
  Next
 End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
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(msoShapeRightArrow, .Left, _
    .Top, .Width, .Height).Fill.Visible = False
   End If
  End With
 Next
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub アクティブセルにセル半分のサイズの→を書く()
  With ActiveCell
    ActiveSheet.Shapes.AddShape(msoShapeRightArrow, _
                                .Left + .Width / 4, _
                                .Top + .Height / 4, _
                                .Width / 2, _
                                .Height / 2) _
                                .Fill.Visible = False
  End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
6 セルの中に、波線を書くには
http://www.keep-on.com/~excelyou/2000lng4/200006/00060191.txt
  「セルに波線を書くには?」 【VBAラウンジ】
Excel97、Excel2000 共通
 1. 図形で直線を引きます。
 2. オートシェイプの書式設定で線の色の線のパターンで右上の大波を選択します。
 3. 線の太さを3ポイントにします。線の太さを6,9…と変えると2重,3重の波線が引けます。
Sub セルの中に波線()
  Dim T As Double, L As Double, W As Double, H As Double
  Dim N As Variant, F As Variant, i As Integer
  If Not TypeName(Selection) = "Range" Then Exit Sub
  With Selection
    T = .Top
    L = .Left
    W = .Width
    H = .Height
  End With
  Do
    N = Application.InputBox("選択範囲にいくつの山を入れますか?", "整数入力", 5, Type:=1)
    If VarType(N) = vbBoolean Then Exit Sub
    If N > 0 And N = Int(N) Then Exit Do
  Loop
  Do
    F = Application.InputBox("線の太さを入力して下さい。", "太さ入力", 1.5, Type:=1)
    If VarType(F) = vbBoolean Then Exit Sub
    If F > 0 Then Exit Do
  Loop
  N = N * 2
  With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, L, T)
    For i = 1 To N Step 2
      .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * i, T + H
      .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * (i + 1), T
    Next
    .ConvertToShape.Line.Weight = F
  End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub セルの中にグラフ省略用の波線() 
 Dim T As Double, L As Double, W As Double, H As Double
 Dim N As Variant, F As Variant, i As Integer, m(2) As String
 If Not TypeName(Selection) = "Range" Then Exit Sub
 With Selection
  T = .Top
  L = .Left
  W = .Width
  H = .Height
 End With
 Do
  N = Application.InputBox("選択範囲にいくつの山を入れますか?", "整数入力", 5, Type:=1)
  If VarType(N) = vbBoolean Then Exit Sub
  If N > 0 And N = Int(N) Then Exit Do
 Loop
 Do
  F = Application.InputBox("二本の線の間隔を入力して下さい。", "間隔入力", 6, Type:=1)
  If VarType(F) = vbBoolean Then Exit Sub
  If F > 0 Then Exit Do
 Loop
 N = N * 2
 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, L, T)
  For i = 1 To N Step 2
   .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * i, T + H
   .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * (i + 1), T
  Next
  m(1) = .ConvertToShape.Name
  ActiveSheet.Shapes(m(1)).Line.Weight = F
 End With
 '外側の黒波線を描画
 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, L, T)
  For i = 1 To N Step 2
   .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * i, T + H
   .AddNodes msoSegmentCurve, msoEditingAuto, L + W / N * (i + 1), T
  Next
  m(2) = .ConvertToShape.Name
 End With
 '内側の白波線を描画
 With ActiveSheet.Shapes(m(2))
  .Line.Weight = F - 3
  .Line.ForeColor.SchemeColor = 9
 End With
 '白・黒線をグループ化
 ActiveSheet.Shapes.Range(Array(m(1), m(2))).Select
 Selection.ShapeRange.Group.Select
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
7 鉄道を現すような、白黒線を書くには
http://www.keep-on.com/~excelyou/2000lng5/200006/00060071.txt
  「罫線の種類について」 【その他ラウンジ】
Excel97、Excel2000 共通
 セルの上と下に普通の罫線をひき、行間隔を詰めて、セルを交互に黒で塗りつぶす。
選択したセル 範囲の中に、任意の数だけ黒色を入れて、グループ化しています。
 Sub 白黒線()
  Dim セル横幅 As Integer, セル縦幅 As Integer, 横位置 As Double, 高さ As Double
  Dim 黒の数 As Variant, 黒線の長さ As Integer, 黒 As Integer, i As Integer, c As Integer
  Dim 図形() As Variant
  If TypeName(Selection) <> "Range" Then Exit Sub
  With Selection
   セル横幅 = .Width
   セル縦幅 = .Height
   横位置 = .Left
   高さ = .Top
  End With
  Do
   黒の数 = Application.InputBox("選択範囲にいくつ黒を入れますか?", "整数入力", 5, Type:=1)
   If VarType(黒の数) = vbBoolean Then Exit Sub
   If 黒の数 > 0 And 黒の数 = Int(黒の数) Then Exit Do
  Loop
  ReDim 図形(1 To 1)
  With ActiveSheet.Shapes
   With .AddShape(msoShapeRectangle, 横位置, 高さ, セル横幅, セル縦幅)
    .Fill.ForeColor.RGB = vbWhite
    図形(1) = .Name
   End With
   黒線の長さ = セル横幅 / 黒の数 / 2
   黒 = 黒の数 * 2 - 1
   c = 1
   For i = 0 To 黒 Step 2
    c = c + 1
    ReDim Preserve 図形(1 To c)
    With .AddShape(msoShapeRectangle, 横位置 + 黒線の長さ * i, 高さ, 黒線の長さ, セル縦幅)
     .Fill.ForeColor.RGB = vbBlack
     図形(c) = .Name
    End With
   Next
   .Range(図形).Group
  End With
 End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
8 太さや幅を指定できる二重線
Private Type RECT
 Left As Single
 Top As Single
 Right As Single
 Bottom As Single
End Type
Sub DoubleLine()
  Dim CellRect As RECT
  Dim OuterRect As RECT
  Dim InnerRect As RECT
  Dim Distance As Variant
  Dim Direction As Variant
  Dim ArrLine() As Variant
  If TypeName(Selection) <> "Range" Then Exit Sub
  Do
   Distance = Application.InputBox("線の間隔を入力して下さい。" & vbCrLf & _
          "Pt単位で(1Ptは1/72インチです。)", Title:="幅", Default:=3, Type:=1)
   If VarType(Distance) = vbBoolean Then Exit Sub
   If Distance > 0 Then Exit Do
  Loop
  Distance = Distance / 2
  Do
   Direction = Application.InputBox("描画場所を指定して下さい。" & vbCrLf & _
            "0:周り 1:上 2:下 3:左 4:右", Title:="作図位置", Default:=0, Type:=1)
   If VarType(Distance) = vbBoolean Then Exit Sub
   Select Case Direction
    Case 0, 1, 2, 3, 4
    Exit Do
   End Select
  Loop
  With Selection
   CellRect.Left = .Left
   CellRect.Top = .Top
   CellRect.Right = .Left + .Width
   CellRect.Bottom = .Top + .Height
  End With
  With OuterRect
   .Left = CellRect.Left - Distance
   .Top = CellRect.Top - Distance
   .Right = CellRect.Right + Distance
   .Bottom = CellRect.Bottom + Distance
  End With
  With InnerRect
   .Left = CellRect.Left + Distance
   .Top = CellRect.Top + Distance
   .Right = CellRect.Right - Distance
   .Bottom = CellRect.Bottom - Distance
  End With
  ReDim ArrLine(1 To 2)
  With ActiveSheet.Shapes
   Select Case Direction
    Case 1 '上
     ArrLine(1) = .AddLine(CellRect.Left, OuterRect.Top, CellRect.Right, OuterRect.Top).Name
     ArrLine(2) = .AddLine(CellRect.Left, InnerRect.Top, CellRect.Right, InnerRect.Top).Name
    Case 2 '下
     ArrLine(1) = .AddLine(CellRect.Left, OuterRect.Bottom, CellRect.Right, _
                 OuterRect.Bottom).Name
     ArrLine(2) = .AddLine(CellRect.Left, InnerRect.Bottom, CellRect.Right, _
                 InnerRect.Bottom).Name
    Case 3 '左
     ArrLine(1) = .AddLine(OuterRect.Left, CellRect.Top, OuterRect.Left, CellRect.Bottom).Name
     ArrLine(2) = .AddLine(InnerRect.Left, CellRect.Top, InnerRect.Left, CellRect.Bottom).Name
    Case 4 '右
     ArrLine(1) = .AddLine(OuterRect.Right, CellRect.Top, OuterRect.Right, _
                                CellRect.Bottom).Name
     ArrLine(2) = .AddLine(InnerRect.Right, CellRect.Top, InnerRect.Right, CellRect.Bottom).Name
    Case Else '周り
     ReDim ArrLine(1 To 8)
     ArrLine(1) = .AddLine(OuterRect.Left, OuterRect.Top, OuterRect.Right, _
                 OuterRect.Top).Name
     ArrLine(2) = .AddLine(InnerRect.Left, InnerRect.Top, InnerRect.Right, InnerRect.Top).Name
     ArrLine(3) = .AddLine(OuterRect.Left, OuterRect.Bottom, OuterRect.Right, _
                 OuterRect.Bottom).Name
     ArrLine(4) = .AddLine(InnerRect.Left, InnerRect.Bottom, InnerRect.Right, _
                   InnerRect.Bottom).Name
     ArrLine(5) = .AddLine(OuterRect.Left, OuterRect.Top, OuterRect.Left, _
                  OuterRect.Bottom).Name
     ArrLine(6) = .AddLine(InnerRect.Left, InnerRect.Top, InnerRect.Left, _   
                 InnerRect.Bottom).Name
     ArrLine(7) = .AddLine(OuterRect.Right, OuterRect.Top, OuterRect.Right, _
                  OuterRect.Bottom).Name
     ArrLine(8) = .AddLine(InnerRect.Right, InnerRect.Top, InnerRect.Right, _
                  InnerRect.Bottom).Name 
   End Select
   .Range(ArrLine).Group
  End With
 End Sub

注意 : A列や1行目で使用すると上(左)の線幅が違ってきます。
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
9 シート内の全ての図形を削除するには
http://www.keep-on.com/~excelyou/2000lng4/200006/00060191.txt
  「セルに波線を書くには?」 【VBAラウンジ】
Sub すべてのオブジェクトを削除()
 Dim s As Object
 With ActiveSheet
  If .ProtectDrawingObjects Then
   MsgBox "図形は保護されています。", vbCritical
  Else
   .DrawingObjects.Delete
   For Each s In .DrawingObjects
    s.Delete
   Next
  End If
 End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub すべてのオートシェイプを削除()
 Dim Sh As Shape
 With ActiveSheet
  If .ProtectDrawingObjects Then
   MsgBox "図形は保護されています。", vbCritical
  Else
   For Each Sh In ActiveSheet.Shapes
    If Sh.Type = msoAutoShape _
     Or Sh.Type = msoLine _
     Or Sh.Type = msoFreeform _
     Or Sh.Type = msoGroup Then
     Sh.Delete
    End If
   Next
  End If
 End With
End Su

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
10 アクティブになっているグラフやテキストなどのオブジェクト名を取得するには
Msgbox Selection.Name
で出ます。が、とにかく選択されているものになってしまうのでセルになったりいろいろになります。
11 図形を指定のセルに移動
http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200105/01050112.txt
  「オートシェイプを印刷するとずれちゃいます(TT)」 【編集ラウンジ】
http://www.keep-on.com/~excelyou/2000lng4/200009/00090051.txt

  「マクロで楕円を任意の場所に貼り付けたいのですが」 【VBAラウンジ】
Sub 指定のセルに図形の中央を合わせる()
 Dim seru As Range
 On Error GoTo Errorline
 Set seru = Application.InputBox("図形を移動するセルをクリックして下さい", "セルの選択", Type:=8)
 With Selection.ShapeRange
  .Left = seru.Left + seru.Width / 2 - .Width / 2
  .Top = seru.Top + seru.Height / 2 - .Height / 2
 End With
 Errorline:
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub 指定のセルに図形の左上位置を合わせる()
 Dim seru As Range
 On Error GoTo Errorline
 Set seru = Application.InputBox("図形を移動するセルをクリックして下さい", "セルの選択", Type:=8)
 With Selection.ShapeRange
  .Left = seru.Left
  .Top = seru.Top
 End With
 Errorline:
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
12 複数の図形を選択し、それぞれの名前、位置などを知るには
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200011/00110404.txt
  「複数の図形を選択し、それぞれの名前、位置などを知るには」 【VBAラウンジ】
図形オブジェクトを複数選択した状態では、Selection プロパティがDrawingObjectsオブジェクトを返します。このコードは、選択した図形がひとつだけの場合は動きません。
結果をイミディエイトウインドウとメッセージボックスの両方に表示します。
Sub Test1()
 Dim obj As Object
 Dim i As Long
 If TypeName(Selection) = "DrawingObjects" Then
  i = 0
  For Each obj In Selection
   i = i + 1
   Debug.Print i, obj.Name, obj.Left, obj.Top, obj.Width, obj.Height
   MsgBox "Name = " & obj.Name & vbCrLf & _
   "Left = " & obj.Left & vbCrLf & _
   "Top = " & obj.Top & vbCrLf & _
   "Width = " & obj.Width & vbCrLf & _
   "Height = " & obj.Height
  Next
 End If
End Sub

以下は、単独の図形を選択した場合にも対応させたコードです。
結果をイミディエイトウインドウとメッセージボックスの両方に表示します。
Sub Test2()
 Dim obj As Object
 Dim i As Long
 On Error Resume Next
 If TypeName(Selection) <> "Range" Then
  i = 0
  For Each obj In Selection.ShapeRange
   i = i + 1
   Debug.Print i, obj.Name, obj.Left, obj.Top, obj.Width, obj.Height
   MsgBox "Name = " & obj.Name & vbCrLf & _
   "Left = " & obj.Left & vbCrLf & _
   "Top = " & obj.Top & vbCrLf & _
   "Width = " & obj.Width & vbCrLf & _
   "Height = " & obj.Height
  Next
 End If
End Sub

  このコードの使い方は、
マクロの使い方(1)標準モジュールにあります。

13 図形の位置を取得するには
Sub 図形の位置取得()
 Dim 左 As Double, 上 As Double, 横幅 As Double, 縦幅 As Double
 Dim 右 As Double, 下 As Double
 If TypeName(Selection) = "Range" Then
  MsgBox "図形が選択されていません", vbCritical
  Exit Sub
 End If
 With Selection.ShapeRange
  If .Count > 1 Then
   MsgBox "図形は複数選択しないでください", vbCritical
   Exit Sub
  End If
  左 = .Left                
'セル の左位置
  上 = .Top               
'セル の上位置
  横幅 = .Width             
'セル の横幅
  縦幅 = .Height            
'セル の縦幅
  右 = 左 + 横幅
             'セル の右位置
  下 = 上 + 縦幅            
'セル の下位置
  MsgBox "左位置は " & Format(左, "0.00") & " です" & vbCrLf & _
  "上位置は " & Format(上, "0.00") & " です" & vbCrLf & _
  "右位置は " & Format(右, "0.00") & " です" & vbCrLf & _
  "下位置は " & Format(下, "0.00") & " です", Title:="図形の位置(ポイント)"
 End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
14 図形の削除各種
Sub 選択した図形を削除()
 Selection.Delete
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub アクティブシートの全ての図形を削除()
 ActiveSheet.DrawingObjects.Delete
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub 三番目に挿入した図形を削除()
 ActiveSheet.DrawingObjects(3).Delete
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub 図形を指定して削除()
 A% = Application.InputBox("消したい図形の番号を入れて下さい", Type:=1)
 Select Case A%
  Case False
   Exit Sub
  Case Else
   ActiveSheet.DrawingObjects(A%).Delete
 End Select
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
Sub 全シートの図形を削除()
 Dim WS As Worksheet
 For Each WS In Worksheets
  WS.DrawingObjects.Delete
 Next WS
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
15 図形のサイズを、セルに入力したミリの数値で変更するには
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200101/01010382.txt
  「図形の自動サイズ変更」 【VBAラウンジ】
セルA1に幅、セルA2に高さをミリ単位で入力します。
Sub test()
 On Error GoTo Trap
 If Range("A1").Value <> 0 And Range("A2").Value <> 0 Then
  With Worksheets("sheet1").Rectangles(1) 'NO1の図形
   .Width = Range("A1") / 0.35 'セル の横幅
   .Height = Range("A2") / 0.35 'セル の縦幅
  End With
 End If
Trap:
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
このマクロでは、A1またはA2の数値を変更すると同時に、図形のサイズが変わります。
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
 On Error GoTo Trap
 If Range("A1").Value <> 0 And Range("A2").Value <> 0 Then
  With Me.Rectangles(1) 'NO1の図形
   .Width = Range("A1") / 0.35 'セル の横幅
   .Height = Range("A2") / 0.35 'セル の縦幅
  End With
 End If
 Trap:
End Sub

  このコードの使い方は、マクロの使い方(2)該当するシートのモジュールにあります。
16 図形をアニメーションのように回転、移動、拡大するには?
http://www.keep-on.com/~excelyou/2000lng4/200007/00070341.txt
  「図形を拡大、縮小するには?」 【VBAラウンジ】
面白いので、試してみて下さい。
 Sub IncrementShape()
  Dim MyShape As Shape
  Dim i As Long
  Set MyShape = ActiveSheet.Shapes.AddShape _
  (msoShapeCan, 100, 100, 100, 100)
  With MyShape
   'Shapeを回転させる
   For i = 1 To 360
    .IncrementRotation 1
    DoEvents
   Next i
   ' 右方向へ移動
   For i = 1 To 300
    .IncrementLeft 1
    DoEvents
   Next i
   ' 図形の中心から拡大
   For i = 1000 To 1050
    .ScaleWidth 0.001 * i, False, msoScaleFromMiddle '(=1)
    .ScaleHeight 0.001 * i, False, msoScaleFromMiddle '(=1)
    DoEvents
   Next i
   '削除
   '.Delete
  End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
17 図形を選択した時、色を変更するには
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200102/01020450.txt
  「図形を選択した時に色を変える」 【VBAラウンジ】
Sub 図の色変更()
 With ActiveSheet.Shapes(Application.Caller)
  If .Fill.ForeColor.SchemeColor = 9 Then
   .Fill.ForeColor.SchemeColor = 18 '塗りつぶし...濃い紺色
   .Line.ForeColor.SchemeColor = 18 '枠線...濃い紺色
  Else
   .Fill.ForeColor.SchemeColor = 9 '塗りつぶし...白
   .Line.ForeColor.SchemeColor = 64 '枠線...自動
  End If
 End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
コードを標準モジュールにコピーした後、図形を右クリック、マクロの登録をしてください。
マクロを登録した図形をクリックすると色が変わります。
このマクロでは、【開始】のマクロを実行すると、
図形を選択してをEnterしただけで選択した図形の色を変えることができるようになります。
【終了】のマクロを実行すると、Enterの設定が元に戻ります。

Sub 開始()
 Application.OnKey "~", "塗替処理"
 Application.OnKey "{ENTER}", "塗替処理"
End Sub
Sub 終了()
 Application.OnKey "{ENTER}"
 Application.OnKey "~"
End Sub

Sub 塗替処理()
 If TypeName(Selection) = "Range" Then Exit Sub
  With Selection.ShapeRange
   If .Fill.ForeColor.SchemeColor = 9 Then
    .Fill.ForeColor.SchemeColor = 18 '塗りつぶし...濃い紺色
    .Line.ForeColor.SchemeColor = 18 '枠線...濃い紺色
   Else
    .Fill.ForeColor.SchemeColor = 9 '塗りつぶし...白
    .Line.ForeColor.SchemeColor = 64 '枠線...自動
   End If
  End With
End Sub

  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。

18 横並び、縦並びの3つの○を書くには?
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200102/01020474.txt
  「オートシェーブで書きたいんですが。」 【VBAラウンジ】
横並び、縦並びの3つの○を書きます。
'円の実験
Sub Test1()
 Call Oval1(1, True)
 ActiveCell.Offset(, 1).Activate
 Call Oval1(2, False)
End Sub
Sub Oval1(intPa As Integer, bolH As Boolean)
 
'引数
 
'intPaint:黒塗りする位置
 'bolH:向き(True:水平方向 False:垂直方向)

 Dim int2R As Integer
 Dim i As Integer
 With ActiveCell
  int2R = .Width / 3
  If int2R > .Height Then int2R = .Height
  For i = 1 To 3
   If bolH Then
   ActiveSheet.Shapes.AddShape(msoShapeOval, _
    .Left + (i - 1) * int2R, .Top, int2R, int2R).Select
   Else
   ActiveSheet.Shapes.AddShape(msoShapeOval, _
    .Left, .Top + (i - 1) * int2R, int2R, int2R).Select
   End If
   If intPa = i Then Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
  Next i
 End With
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
上の○を、それぞれポイントで指定した間隔を空けて書きます。
Sub Test2()
 Call Oval2(1, 5, True)
'間隔5Pt・横並びの○3つを描画(左端が●)
 ActiveCell.Offset(, 1).Activate
 Call Oval2(1, 5, False)
'間隔5Pt・縦並びの○3つを描画(上端が●)
End Sub
Sub Oval2(intPa As Integer, intSeW As Integer, bolH As Boolean)
 Dim int2R As Integer
 Dim i As Integer
 With ActiveCell
  int2R = .Width / 3
  If int2R > .Height Then int2R = .Height
  For i = 1 To 3
   If bolH Then
    ActiveSheet.Shapes.AddShape(msoShapeOval, _
                 .Left + (i - 1) * (int2R + intSeW), .Top, int2R, int2R).Select
   Else
    ActiveSheet.Shapes.AddShape(msoShapeOval, _
                 。Left, .Top + (i - 1) * (int2R + intSeW), int2R, int2R).Select
   End If
   If intPa = i Then Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
  Next i
 End With
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
19 図形描画で半円を描くには?
http://cgi.fuji.ne.jp/~fj2094/cgi-bin3/wwwlng.cgi?print+200104/01040022.txt
  「図形描画で半円を」 【グラフ・図ラウンジ】
Sub Test()
 With ActiveCell
  With ActiveSheet.Shapes.AddShape(msoShapeBlockArc, .Left, .Top, 72#, 72#)
   .Adjustments.Item(1) = 0#
   .Adjustments.Item(2) = 0#
   .Flip msoFlipVertical
  End With
 End With
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。
20 選択範囲に一回り小さい四角形を描くには?
http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200105/01050043.txt
  「こんなのありますか?」 【VBAラウンジ】
選択した範囲に、一つだけ四角形を書きます。
Sub 四角形記入()
 Const 余白率 = 20 '余白の割合(%)
 Dim 座標1 As Double, 座標2 As Double, 座標3 As Double, 座標4 As Double
 If TypeName(Selection) <> "Range" Then Exit Sub
 With Selection
  座標1 = .Left + .Width * 余白率 / 100
  座標2 = .Top + .Height * 余白率 / 100
  座標3 = .Width * (100 - (余白率 * 2)) / 100
  座標4 = .Height * (100 - (余白率 * 2)) / 100
 End With
 ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
          座標1, 座標2, 座標3, 座標4).Fill.ForeColor.SchemeColor = 13
End Sub

  このコードの使い方は、
マクロの使い方(1)標準モジュールにあります。
選択した範囲の全てのセルに、 余白の割合を指定して四角形を書きます。
Sub 選択範囲のセルに四角形を一つづつ記入()
 Dim 座標1 As Double, 座標2 As Double, 座標3 As Double, 座標4 As Double
 Dim 余白率 As Variant, c As Range
 Do
  余白率 = Application.InputBox(Prompt:="余白の割合(10〜40)を入力してください", _
                            Default:=20, Type:=1)
  If VarType(余白率) = vbBoolean Then Exit Sub
  If 余白率 >= 10 And 余白率 <= 40 Then Exit Do
 Loop
  If TypeName(Selection) <> "Range" Then Exit Sub
 For Each c In Selection
  With c.MergeArea
   If c.Address = .Item(1).Address Then
    座標1 = c.Left + c.Width * 余白率 / 100
    座標2 = c.Top + c.Height * 余白率 / 100
    座標3 = c.Width * (100 - (余白率 * 2)) / 100
    座標4 = c.Height * (100 - (余白率 * 2)) / 100
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
               座標1, 座標2, 座標3, 座標4).Fill.ForeColor.SchemeColor = 13
   End If
  End With
 Next
End Sub
  このコードの使い方は、マクロの使い方(1)標準モジュールにあります。

HOME  検索  索引  もくじ  関数目次ージへ        次ページへ

このページのTOPへ

 

 

inserted by FC2 system