Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


29904 / 76733 ←次へ | 前へ→

【52102】Addlineで作った図形の塗りつぶしについて
質問  ちゃや  - 07/10/21(日) 9:35 -

引用なし
パスワード
   エクセル上に表1と表2があります。表1には三角形の番号とその各三角形の節点1,節点2,節点3が記してあり、表2には、節点番号とその各節点番号のX座標,Y座標が記してあります。
(例1)表1の節点1,節点2,節点3は節点番号のことなので、三角形の番号が1の場合、表2を見ると節点番号が1,7,8のときの各X座標・Y座標は、それぞれ(X座標,Y座標)=(0,0),(0,6),(10,6)となっています。
下記のプログラムではまず表2から、各節点のX座標、Y座標を順次取得していき、MinX,MinY,MaxX,MaxYを求めます。それらから図を描画するときに使うRatio,Base左,Base下を求めます。次に表1と表2から節点1、節点2、節点3の書くX座標、Y座標を取得し(例1のように)Shapes.Addlineを使って、三角形を表1にあるように50個描画していきます。
これで下記のプログラムは終了するのですが、50個描画したうちのいくつかの三角形を青で塗りつぶしたいと考えています。たとえば表1の番号2,3,4の三個の三角形を塗りつぶすなどです。Shapes.Addlineを使った描画ではやはり塗りつぶすことはできないのでしょうか??50個描画したうちのいくつかの三角形を塗りつぶす方法を探しています。よろしくお願いします。

     表1
番号    節点1    節点2    節点3
1    1    7    8
2    1    2    8
3    2    8    9
4    2    3    9
5    3    9    10
6    3    4    10
7    4    10    11
8    4    5    11
9    5    11    12
10    5    6    12
11    7    13    14
12    7    8    14
13    8    14    15
14    8    9    15
15    9    15    16
16    9    10    16
17    10    16    17
18    10    11    17
19    11    17    18
20    11    12    18
21    13    19    20
22    13    14    20
23    14    20    21
24    14    15    21
25    15    21    22
26    15    16    22
27    16    22    23
28    16    17    23
29    17    23    24
30    17    18    24
31    19    25    26
32    19    20    26
33    20    26    27
34    20    21    27
35    21    27    28
36    21    22    28
37    22    28    29
38    22    23    29
39    23    29    30
40    23    24    30
41    25    31    32
42    25    26    32
43    26    32    33
44    26    27    33
45    27    33    34
46    27    28    34
47    28    34    35
48    28    29    35
49    29    35    36
50    29    30    36

    表2
番号    座標X    座標Y
1    0    0
2    10    0
3    20    0
4    30    0
5    40    0
6    50    0
7    0    6
8    10    6
9    20    6
10    30    6
11    40    6
12    50    6
13    0    12
14    10    12
15    20    12
16    30    12
17    40    12
18    50    12
19    0    18
20    10    18
21    20    18
22    30    18
23    40    18
24    50    18
25    0    24
26    10    24
27    20    24
28    30    24
29    40    24
30    50    24
31    0    30
32    10    30
33    20    30
34    30    30
35    40    30
36    50    30


Private Sub CommandButton1_Click()

Dim i As Integer
  Dim 枠左 As Single, 枠上 As Single
  Dim 枠幅 As Single, 枠高 As Single
  Dim 節点の数, 要素の数, 変位倍率, 座標X(), 座標Y()
  Dim 節点1, 節点2, 節点3
  Dim MinX As Single, MinY As Single
  Dim MaxX As Single, MaxY As Single
  Dim Base左 As Single, Base下 As Single, Ratio As Double

  枠左 = Range("f10:l32").Left + 余白
  枠上 = Range("f10:l32").Top + 余白
  枠幅 = Range("f10:l32").Width - 余白 * 2
  枠高 = Range("f10:l32").Height - 余白 * 2

  
    節点の数 = Range("m3")
    Dim 座標Xi, 座標Yi
    For i = 1 To 節点の数
      座標Xi = Range("n5").Offset(i, 0)
      座標Yi = Range("o5").Offset(i, 0)
    Next i
    座標X1 = Range("n6")
    
    座標Y1 = Range("o6").Value
    
    
    MinX = 座標X1
    MinY = 座標Y1
    MaxX = 座標X1
    MaxY = 座標Y1
    For i = 2 To 節点の数
      If MinX > 座標Xi Then MinX = 座標Xi
      If MinY > 座標Yi Then MinY = 座標Yi
      If MaxX < 座標Xi Then MaxX = 座標Xi
      If MaxY < 座標Yi Then MaxY = 座標Yi
    Next i
    If MaxX - MinX > MaxY - MinY Then
      Ratio = 枠幅 / (MaxX - MinX)
      Base左 = 枠左 - MinX * Ratio
      Base下 = 枠上 + 枠高 - MinY * Ratio _
            - (枠高 - (MaxY - MinY) * Ratio) / 2
    Else
      Ratio = 枠高 / (MaxY - MinY)
      Base左 = 枠左 - MinX * Ratio _
            + (枠幅 - (MaxX - MinX) * Ratio) / 2
      Base下 = 枠上 + MaxY * Ratio
    End If
    
        Dim 表1 As Range
  Dim 表2 As Range
  Dim v As Variant

  
  Set 表1 = Range("Q5:T35")
  Set 表2 = Range("M5:O41")
  With 表1
    For i = 2 To .Rows.Count ' 実データである2行目から
     
        v = Application.Match(.Cells(i, 2), 表2.Columns(1), 0)
        vv = Application.Match(.Cells(i, 3), 表2.Columns(1), 0)
        vvv = Application.Match(.Cells(i, 4), 表2.Columns(1), 0)
                    座標X節点1 = 表2.Cells(v, 2)
          座標Y節点1 = 表2.Cells(v, 3)
          座標X節点2 = 表2.Cells(vv, 2)
          座標Y節点2 = 表2.Cells(vv, 3)
          座標X節点3 = 表2.Cells(vvv, 2)
          座標Y節点3 = 表2.Cells(vvv, 3)


        Shapes.AddLine Base左 + 座標X節点1 * Ratio _
              , Base下 - 座標Y節点1 * Ratio _
              , Base左 + 座標X節点2 * Ratio _
              , Base下 - 座標Y節点2 * Ratio
        Shapes.AddLine Base左 + 座標X節点2 * Ratio _
              , Base下 - 座標Y節点2 * Ratio _
              , Base左 + 座標X節点3 * Ratio _
              , Base下 - 座標Y節点3 * Ratio
        Shapes.AddLine Base左 + 座標X節点3 * Ratio _
              , Base下 - 座標Y節点3 * Ratio _
              , Base左 + 座標X節点1 * Ratio _
              , Base下 - 座標Y節点1 * Ratio
      
    Next i
End With
  END SUB
2 hits

【52102】Addlineで作った図形の塗りつぶしについて ちゃや 07/10/21(日) 9:35 質問
【52104】Re:Addlineで作った図形の塗りつぶしについ... ichinose 07/10/21(日) 11:15 発言
【52105】Re:Addlineで作った図形の塗りつぶしについ... ichinose 07/10/21(日) 11:25 発言
【52106】Re:Addlineで作った図形の塗りつぶしについ... ちゃや 07/10/21(日) 13:22 質問
【52111】Re:Addlineで作った図形の塗りつぶしについ... りん 07/10/21(日) 15:16 発言
【52115】Re:Addlineで作った図形の塗りつぶしについ... ちゃや 07/10/21(日) 20:21 質問
【52114】Re:Addlineで作った図形の塗りつぶしについ... ichinose 07/10/21(日) 19:50 発言
【52159】Re:Addlineで作った図形の塗りつぶしについ... ちゃや 07/10/25(木) 18:31 質問
【52160】Re:Addlineで作った図形の塗りつぶしについ... ichinose 07/10/25(木) 21:19 発言

29904 / 76733 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free