1 Option Explicit
2
3 Public svcs As Object
4 Public topsvc As svc
5
6 'セル定義
7 Const spinButtonTop As String = "g7"
8 Const spinButtonTop2 As String = "h7"
9 Const firstLine As String = "a12"
10 Const propbase As String = "b11"
11
12 Public canvasX As Integer
13 Public canvasY As Integer
14
15 Dim l As LocalAxis
16
17 Sub 更新_Click()
18 Call updateGentens
19 Call initSvcs
20 Call draw
21 End Sub
22
23
24 Public Sub SpinButton1_SpinUp()
25
26 Call initSvcs
27
28 '値変更
29 Dim targetName As String: targetName = Range(firstLine).Offset(Range(spinButtonTop).Value - 1, 0).Value
30 Dim propName As String: propName = Range(propbase).Offset(0, Range(spinButtonTop2).Value - 1).Value
31
32 Dim thissvc As svc: Set thissvc = svcs(targetName)
33 thissvc.cells(propName).Value = thissvc.cells(propName).Value + 1
34
35 Call draw
36
37 End Sub
38 Public Sub SpinButton1_SpinDown()
39
40 Call initSvcs
41
42 '値変更
43 Dim targetName As String: targetName = Range(firstLine).Offset(Range(spinButtonTop).Value - 1, 0).Value
44 Dim propName As String: propName = Range(propbase).Offset(0, Range(spinButtonTop2).Value - 1).Value
45
46 Dim thissvc As svc: Set thissvc = svcs(targetName)
47 thissvc.cells(propName).Value = thissvc.cells(propName).Value - 1
48
49 Call draw
50
51 End Sub
52
53
54 Private Sub initSvcs()
55 Debug.Print "initSvcs"
56 Set svcs = CreateObject("Scripting.Dictionary")
57 Dim thissvc As svc
58 Dim parentsvc As svc
59
60 '定義行　読み取り
61 Dim i As Integer: i = 0
62 While Not Range(firstLine).Offset(i, 0).Value = ""
63 Set thissvc = New svc
64 thissvc.cells.Add "name", Range(firstLine).Offset(i, 0)
65 thissvc.cells.Add "parentName", Range(firstLine).Offset(i, 1)
66 thissvc.cells.Add "xFromParent", Range(firstLine).Offset(i, 2)
67 thissvc.cells.Add "yFromParent", Range(firstLine).Offset(i, 3)
68 thissvc.cells.Add "originX", Range(firstLine).Offset(i, 4)
69 thissvc.cells.Add "originY", Range(firstLine).Offset(i, 5)
70 thissvc.cells.Add "kakudo", Range(firstLine).Offset(i, 6)
71
72 svcs.Add thissvc.cells("name").Value, thissvc
73
74 i = i + 1
75 Wend
76
77 '親子関係作成
78 Dim key As Variant
79 For Each key In svcs
80 Set thissvc = svcs(key)
81 Dim parentName As String: parentName = thissvc.cells("parentName").Value
82 If parentName = "none" Then
83 Set topsvc = thissvc
84 Else
85 Set parentsvc = svcs(parentName)
86 parentsvc.children.Add thissvc.cells("name").Value, thissvc
87 End If
88 Next key
89
90 End Sub
91 Private Sub updateGentens()
92 Debug.Print "updateGentens"
93 Debug.Print "1"
94 'Set currentSVC = svcs(targetName)
95
96 Debug.Print "1"
97 Dim genten1 As shape: Set genten1 = ActiveSheet.Shapes("円/楕円 3")
98 canvasX = genten1.Left + genten1.Width / 2
99 canvasY = genten1.Top + genten1.Height / 2
100
101 Debug.Print "1"
102
103 End Sub
104 Private Sub draw()
105 Debug.Print "draw"
106 Set l = New LocalAxis
107 l.currentName = Range(firstLine).Offset(Range(spinButtonTop).Value - 1, 0).Value
108
109 Call l.save
110 Call l.translate(canvasX, canvasY)
111 Call draw_recursive(topsvc)
112 Call l.restore
113
114 End Sub
115 Private Sub draw_recursive(thissvc As svc)
116 Debug.Print "draw_recursive"
117 Dim thisName As String: thisName = thissvc.cells("name").Value
118 Dim thisshape As shape: Set thisshape = ActiveSheet.Shapes(thisName)
119 Dim parentName As String: parentName = thissvc.cells("parentName").Value
120 Dim thisXFromParent As Integer: thisXFromParent = thissvc.cells("xFromParent").Value
121 Dim thisYFromParent As Integer: thisYFromParent = thissvc.cells("yFromParent").Value
122 Dim thisOriginX As Integer: thisOriginX = thissvc.cells("originX").Value
123 Dim thisOriginY As Integer: thisOriginY = thissvc.cells("originY").Value
124 Dim thisKakudo As Integer: thisKakudo = thissvc.cells("kakudo").Value
125
126 l.save
127 Call l.translate(thisXFromParent, thisYFromParent)
128 Call l.rotateByKakudo(thisKakudo)
129 Call l.shapeDraw(thisshape, -thisOriginX, -thisOriginY)
130
131
132 Dim key As Variant
133 For Each key In thissvc.children
134 Dim childsvc As svc: Set childsvc = thissvc.children(key)
135
136 Call draw_recursive(childsvc)
137 Next key
138 l.restore
139
140 End Sub