Excel VBAで図形を描く方法

前へ 次へ
このQ&Aのポイント
  • Excel VBAで任意の位置と大きさの四角を描く方法を解説します。
  • オートシェイプを使ってExcel VBAで四角を描く手順を紹介します。
  • VBAコードを使用して、Excelの図形を自由に描く方法について説明します。
回答を見る
  • ベストアンサー

Excel VBA で図形を描く方法について

Excel VBA初心者です。 Excel のオートシェイプで任意の四角を描くには、始点をマウスでクリックし対角にドラッグすれば自由な四角が描けますが、VBAでこれを行なう場合、どのように記述すればいいのでしょうか？。 Excel は2003です。 いろいろ調べてみると… 一例ですが… Set Shp = WS.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 40) このような記述をよく目にします。 恐らくこれは始点（50,50）、四角の大きさ（100,40）となると思います。 私がVBAで描きたいのは、マウスを使った任意の位置と大きさの四角と丸です。 説明が下手で申し訳ありませんが、よろしくお願いします。

質問者が選んだベストアンサー

  • ベストアンサー
  • end-u
  • ベストアンサー率79% (496/625)
回答No.1

>私がVBAで描きたいのは、マウスを使った任意の位置と大きさの四角と丸です。 例えばマクロの流れの中でユーザーに操作させたい、という意味でしょうか。 If MsgBox("drawing?", vbYesNo) = vbYes Then 　　'[四角形(&R)]のコマンドボタン(ID:=1111)を押す動作。楕円(&O)は1119 　　Application.CommandBars.FindControl(ID:=1111).Execute 　　'または以下と差し替えても良い。 　　'Application.CommandBars.FindControl(ID:=1111).accDoDefaultAction End If

luke0408
質問者

お礼

end-u 様 いろいろやってみたら期待通りに動いてくれました。 ありがとうございます。

luke0408
質問者

補足

end-u 様 ご回答、ありがとうございます。 >例えばマクロの流れの中でユーザーに操作させたい、という意味でしょうか。 そうです。その通りです。 説明不足で申し訳ありません。 end-u 様のご回答を早速試してみました。 "drawing?"とメッセージが出て、「はい」を選択しますが何も起こらず「はい」を押した瞬間に終了してしまいます。 Public Sub a1() If MsgBox("drawing?", vbYesNo) = vbYes Then '[四角形(&R)]のコマンドボタン(ID:=1111)を押す動作。楕円(&O)は1119 Application.CommandBars.FindControl(ID:=1111).Execute 'または以下と差し替えても良い。 'Application.CommandBars.FindControl(ID:=1111).accDoDefaultAction End If End Sub 現在の記述です。 何か足りないのでしょうか？

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • Ｅｘｃｅｌ　 VBAで　図形を描いてその中に文字を。

    教えて下さい。 エクセル2007　ＶＢＡで オートシェイプでフローチャートの三角形を描いて、 その中に「検索」などの文字を表示させることが必要になってきました。 どのように記述すればいいのですか？ ＞ActiveSheet.Shapes.AddShape msoShapeIsoscelesTriangle, 560, 60, 70, 80 これで三角形は描画できますが、その中に文字を記入させるにはどうすればいいのかを教えて下さい。よろしくお願いします。

  • ShapeのVBAの中での取り扱い

    ShapeのVBAの中での取り扱いに関して、サジェスチョン願います。 Shapeに文字が書き込まれていない段階で、選択して文字を読み込み判定しようとするとエラーとなります。 下記のVBAでは、5番目のShapeが該当します。 このエラーを防ぐためには、On Error Resume Nextが有効ですが、他の方法を探しています。例えば、charactor=trueみたいなもの。 ----- Sub Shapeの調査() Dim nametemp(10) As String Dim temp As Integer Dim i As Integer Dim aaa As Variant 'On Error Resume Next ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50).Select ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 150, 150, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200, 200, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeOval, 250, 250, 50, 50).Select temp = ActiveSheet.Shapes.Count For i = 1 To temp ActiveSheet.Shapes(i).Select nametemp(i) = ActiveSheet.Shapes(i).Name Next For i = 1 To temp / 2 + 1 '4つのshapeに対し、文字を書き込もうとする ActiveSheet.Shapes(nametemp(i)).Select Selection.Characters.Text = "" Next For i = 1 To temp / 2 '3つに対して、文字を書き込む ActiveSheet.Shapes(nametemp(i)).Select Selection.Characters.Text = "zzzzz" Next For i = 1 To temp ActiveSheet.Shapes(nametemp(i)).Select aaa = Selection.Characters.Text '<--5番目のShapeに対し If aaa = "zzzzz" Then MsgBox (aaa)'<--errorとなる。 Next End Sub

  • 特定の名前のオートシェイプの有無を知りたい（エクセルVBA）

    Excel VBA で、オートシェイプを扱おうとしています。 たとえば、 ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 50, 50).Name = "TestShape1" のようにして、それぞれ名前を付けているのですが、プログラム中、特定のオートシェイプを削除したり、再び同じ名前で作ったり、ということを行っています。 前者の場合、すでに当該オートシェイプが削除されている場合、目的のオートシェイプが存在していないためか、エラーが発生します。また後者の場合も、オートシェイプを重ねて作成することになってしまうケースにエラーが発生します。 On Error Resume Next で回避することも考えられるでしょうが、もっと直接的に、ある名前のオートシェイプが存在する／しない、をチェックしたうえで各処理を行うようにしたいのです。 どのような方法があるでしょうか？

  • エクセルＶＢＡで画像を回転させる方法

    エクセル２０００です。 ワークシートに貼り付けた図形などのオートシェープは下記のＶＢＡで任意の角度を回転させることが出来ますね。 Sheet1.Shapes("AutoShape 1").IncrementRotation (5) 同様に貼り付けた写真などの画像を回転させるにはどうすればいいのでしょうか？ Sheet1.Shapes("Picture 2").IncrementRotation (5) ではまったく回転しませんでした。 どうか教えてください。

  • 円弧の描画について

    エクセルのワークシート上に2点(x1,y1)、(x2,y2)の座標があり、半径がrと決まっている場合に、(x1,y1)を始点、(x2,y2)を終点とする半径rの円弧を描きたいのですが、VBAで教えていただけますでしょうか？ 例えばエクセルのワークシート上に2点(600,400)と(500,300)という座標があります。この座標は、 Dim ShapeA As Shape, ShapeB As Shape Set ShapeA = ActiveSheet.Shapes.AddShape _ (msoShapeOval, 600, 400, 2, 2) Set ShapeB = ActiveSheet.Shapes.AddShape _ (msoShapeOval, 500, 300, 2, 2) というコードでワークシート上に描いています。 この2点をそれぞれ始点、終点として、半径100の円弧を描く方法を考えているのですが、 VBA初心者の為、困っています。VBAで円弧を描く方法がありましたら是非教えていただきたく お願い致します。 よろしくお願い致します。

  • Excelで指定のセル上に図を配置したい

    Excel VBAで、シート上に図（四角形）を配置しようと思ってます。 イメージ的には、ALTキーを押しながらセルとぴったりフィットする図形（四角形）を作成したいのですが、マクロで生成したコードを見ると下記のように座標での指定になってます。 ActiveSheet.Shapes.AddShape(msoShapeRectangle, 102#, 210#, 76.5, 15#).Select もしこれをセルで指定する方法がありましたら教えて下さい。宜しくお願いします。

  • オートシェープをグルーピングして動作させたい

    office365 ２つのオートシェープをグルーピングして図形を動作させたい 下記で kibanは平行四辺形のオートシェープ yajirushiは右向き矢印のオートシェープ で、それぞれ、ある範囲で左から右に移動を繰り返します。 この２つのオートシェープをグルーピングして 平行四辺形の右側に矢印を配置した状態で、そのグルーピングされた図形の動作を繰り返す様にしたいのですが、 その内容が分からないのでコードで教えていただきたく、よろしくお願いします。 #If Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else ' Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Sub kiban() shape_delete Dim ws2 As Worksheet Dim i As Integer Set ws2 = Sheets("sheet1") ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 354, 46, 20).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 80) .Transparency = 0 .Solid End With ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 458, 20, 20).Select ws2.Shapes(ws2.Shapes.Count).name = "kiban" For i = 0 To 30 If i = 30 Then i = 0 End If ws2.Shapes(1).Left = i * 3 + 365 ws2.Shapes(1).Top = 458 Sleep 100 DoEvents Next i ws2.Shapes("kiban").delete End Sub Sub yajirushi() shape_delete Dim ws As Worksheet Dim i As Integer Set ws = Sheets("sheet1") ws.Shapes.AddShape msoShapeRightArrow, 2265, 458, 20, 20 ws.Shapes(ws.Shapes.Count).name = "yajirushi" For i = 0 To 30 If i = 30 Then i = 0 End If ws.Shapes(1).Left = i * 3 + 420 ws.Shapes(1).Top = 458 Sleep 100 DoEvents Next i ws.Shapes("yajirushi").delete End Sub Sub shape_delete() Dim shp As Shape Dim rng As Range Range("P22:CM28").Select If TypeName(Selection) <> "Range" Then Exit Sub For Each shp In ActiveSheet.Shapes '‘ 図形の配置されているセル範囲をオブジェクト変数にセット Set rng = Range(shp.TopLeftCell, shp.BottomRightCell) '‘ 図形の配置されているセル範囲と '‘ 選択されているセル範囲が重なっているときに図形を削除 If Not (Intersect(rng, Selection) Is Nothing) Then shp.delete End If Next End Sub

  • エクセルVBAで直線図形(オートシェイプ)を書きたいのですが。

    エクセルVBAで直線図形(オートシェイプ)を書きたいのですが。座標の指定方法がいまひとつ分かりません。 マクロの記録で、座標数値の設定は分かるのですが、セルに対しての指定方法が分かりません。 図形をドラッグ指定したＡ１セルからＣ１セルまで直線を書きたいのです。セルへの始点終点の指定方法が有るのでしょうか。

  • エクセルVBA　オートシェイプを操作したいです

    エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。 http://oshiete1.goo.ne.jp/qa809742.htmlで見つかったものを参考にし、 Private Sub worksheet_Activate() Dim Shp As Shape Set P11 = Range("P11") If P11 Is Nothing Then Exit Sub If P11.Value = 1 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N14:N15") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left,TOP:=.TOP,Width:=.Width,Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N14").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp End If If P11.Value = 2 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N16") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left, TOP:=.TOP, Width:=.Width, Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N16").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp End If End Sub とつなげて見ました。 動くには動くのですが、データ元のセルがP11からT30と100セルあり、さらにP11に入力されるデータが１，２，３，４の4種類、AQ11に５，６，７，８，９の5種類などと、ばらばらです。 P11に１が入力されるとN14:N15(結合されています)に円が入り、２が入力されるとN16に円が入る。 Q11に５が入力されるとR13に円が入り、６が入力されるとR14:R15に円が入る・・・・のようにしたいのです。 一生懸命、セルNo.を打ち込んでいたら、 「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。

  • VB6 オートシェイプ描画

    VB6 オートシェイプ描画 VB6でExcel,2000(ActiveSheet)にオートシェイプを使用したいのですが、エラーが出てしまいます。 コマンドボタンクリック時、エラー ------------------------------- 実行時エラー'1004': 指定された値は境界を超えています。 ------------------------------- AddLineは出来たのですが四角や円がこのエラーです。どこが間違えているのでしょうか？ 宜しくお願いします。 Private Sub CB13_Click() Dim xlApp As Excel.Application Set xlApp = GetObject(, "Excel.Application") xlApp.ActiveSheet.Shapes.AddLine 50, 50, 100, 100 '(OK) xlApp.ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 100).Select '(NG) Set xlApp = Nothing End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する