[[20080129130423]]　『オプションボタン選択で図形貼り付け』（fuwari）　ページの最後に飛ぶ

『オプションボタン選択で図形貼り付け』（fuwari）

ご教授ください。VBA超初心者です。
ユーザーフォームを作成し、フォーム上にフレームがあります。フレームの中にはオプションボタン1とオプションボタン2を配置しています。
オプションボタン1を選択したときに図形の円をセルA1に、オプションボタン2を選択するとA1が消えA2に図形の円を挿入したいのですが、うまく行きません。

 シェイプを移動する、ではだめですか？
 シェイプ.Top = Worksheets("Sheet1").Range("A2").Top

 A1、A2どちらにも表示しない場合は
 シェイプ.Visible = False
 で。
 (MARBIN)

 こんなんでもOKですか？(ROUGE)
'----
Private Sub OptionButton1_Click()
Dim sp As Shape, r As Range
Call sp_del
Set r = Range("A1")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1), pc(r, 2), pc(r, 3), pc(r, 3))
End Sub
Private Sub OptionButton2_Click()
Dim sp As Shape, r As Range
Call sp_del
Set r = Range("A2")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1), pc(r, 2), pc(r, 3), pc(r, 3))
End Sub
Private Sub sp_del()
Dim sp As Shape
For Each sp In ActiveSheet.Shapes
    If Not Intersect(Range("A1:A2"), _
        Range(sp.TopLeftCell, sp.BottomRightCell)) Is Nothing Then
        sp.Delete
    End If
Next
End Sub
Private Function pc(r As Range, i As Integer) As Single
With WorksheetFunction
    Select Case i
        Case 1
            pc = r.Left + r.Width / 2 - .Min(r.Height, r.Width) / 2
        Case 2
            pc = r.Top + r.Height / 2 - .Min(r.Height, r.Width) / 2
        Case 3
            pc = .Min(r.Height, r.Width)
    End Select
End With
End Function

MARBINさん　ROUGEさん　　
早速ありがとうございます。
試してみます。

試したところ、ROUGEさんのコードでうまく動作しました。さらに教えて頂きたいのですが、挿入の場所や、シェイプの設定などを変えて挿入したいです。ROUGEさんのサンプルコードを参考に自分で記録したマクロと組み合わせて試しましたが、うまく動作しません。もう一度ご教授頂けますでしょうか。宜しくお願い致します。

下が、私の記録したマクロです。

オプションボタン1で表示させたい設定
Sub Macro4()
'
' Macro4 Macro
' マクロ記録日 : 2008/1/29 ユーザー名 :
'

    ActiveSheet.shapes.AddShape(msoShapeOval, 848.25, 256.5, 68.25, 61.5).Select
    Selection.ShapeRange.IncrementLeft -1.5
    Selection.ShapeRange.IncrementTop -5.25
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65
    Selection.ShapeRange.Fill.Transparency = 1#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End Sub

オプションボタン2で表示させたい設定
Sub Macro7()
'
' Macro7 Macro
' マクロ記録日 : 2008/1/29 ユーザー名 :
'

    ActiveSheet.shapes.AddShape(msoShapeOval, 897#, 374.25, 64.5, 64.5).Select
    Selection.ShapeRange.IncrementLeft 29.25
    Selection.ShapeRange.IncrementTop -124.5
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 65
    Selection.ShapeRange.Fill.Transparency = 1#
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
End Sub

 どのように設定を変えたいのでしょうか。
 提示されたコードでは分かりかねます。。。orz
 (ROUGE)

言葉足らずですみませんでした。

設定を変えたい部分は図の書式で、オートシェイブの書式設定で塗りつぶしの透明を100％にしています。また貼り付けたい場所は私のブック上でF6のセルです。同じセルの中に新規・継続という文字があり、オプションボタンを選択することにより、どちらかに○を付けたいのです。○を貼り付ける作業のみを記録したのが、上記のマクロです。すみません、説明が下手ですが、可能でしょうか。

 >同じセルの中に新規・継続という文字があり
 とのことですので、微調整はご自身でされるしかないかと。
 当方、MSPゴシック、11ポイント、左詰とし、以下でうまくいきました。
 (ROUGE)
'----
Private Sub OptionButton1_Click()
Dim sp As Shape, r As Range, obj As Object
Set obj = Selection
Call sp_del
Set r = Range("F6")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, r.Left, pc(r, 2), pc(r, 3) * 1.8, pc(r, 3))
sp.Select
Selection.ShapeRange.Fill.Visible = False
obj.Select
End Sub
Private Sub OptionButton2_Click()
Dim sp As Shape, r As Range, obj As Object
Set obj = Selection
Call sp_del
Set r = Range("F6")
Set sp = ActiveSheet.Shapes.AddShape _
(msoShapeOval, pc(r, 1) + 10, pc(r, 2), pc(r, 3) * 1.8, pc(r, 3))
sp.Select
Selection.ShapeRange.Fill.Visible = False
obj.Select
End Sub
Private Sub sp_del()
Dim sp As Shape
For Each sp In ActiveSheet.Shapes
    If Not Intersect(Range("F6"), _
        Range(sp.TopLeftCell, sp.BottomRightCell)) Is Nothing Then
        sp.Delete
    End If
Next
End Sub
Private Function pc(r As Range, i As Integer) As Single
With WorksheetFunction
    Select Case i
        Case 1
            pc = r.Left + r.Width / 2 - .Min(r.Height, r.Width) / 2
        Case 2
            pc = r.Top + r.Height / 2 - .Min(r.Height, r.Width) / 2
        Case 3
            pc = .Min(r.Height, r.Width)
    End Select
End With
End Function

 別セルならば、ぴったりできますよ。。。

ありがとうございます！　うまくいきました。あとは微調整も出来るようにがんばってみます。

コメント返信：

[ 一覧(最新更新順) ]

[[20080129130423]] 『オプションボタン選択で図形貼り付け』（fuwari） ページの最後に飛ぶ

[[20080129130423]]　『オプションボタン選択で図形貼り付け』（fuwari）　ページの最後に飛ぶ