| |
エクセル上に表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座標を順次取得していき、ＭinX,MinY,ＭaxX,ＭaxYを求めます。それらから図を描画するときに使うＲatio,Base左,Base下を求めます。次に表1と表2から節点1、節点2、節点3の書くX座標、Y座標を取得し（例1のように）Ｓhapes.Addlineを使って、三角形を表1にあるように50個描画していきます。
これで下記のプログラムは終了するのですが、50個描画したうちのいくつかの三角形を青で塗りつぶしたいと考えています。たとえば表1の番号2,3,4の三個の三角形を塗りつぶすなどです。Ｓhapes.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 ' 実データである２行目から
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
|
|
ちゃや
- 07/10/21(日) 9:35 -
