玩一玩简单的分形：“尸米”上最强大的谢尔宾斯基三角形

aoe1981

这个主题似乎做过了：

玩一玩简单的分形：谢尔宾斯基三角形
http://club.excelhome.net/thread-1517120-1-1.html
(出处: ExcelHome技术论坛)



今天直接说“强大”之处：

（1）正三角形（五心合一）：


（2）垂足三角形：




（3）中点三角形：



（4）角分点三角形：




（5）周界中点三角形：




（6）三角形“五心”计算自定义函数：




a.可以返回：三个垂足、三个中点、三个角分点、三个周界中点的坐标；

b.可以返回：垂心、重心、外心、内心、界心的坐标。

工具性自定义函数如下：

一级自定义函数：

1. Option Explicit
   
2. Public Function ChuiZu(dd, Optional n% = 0) '1.根据三角形顶点坐标计算垂足坐标（3*2下标相同）或返回垂心坐标（1*2）
   
3.     On Error Resume Next
   
4.     Dim i&, i1&, i2&, i3&, j1&, j2&, k1#, b1#, k2#, b2#
   
5.     If TypeName(dd) = "Range" Then dd = dd.Value
   
6.     j1 = UBound(dd, 1) - LBound(dd, 1) + 1
   
7.     j2 = UBound(dd, 2) - LBound(dd, 2) + 1
   
8.     ReDim cz(1 To 1, 1 To 1)
   
9.     If err.Number = 13 Then
   
10.         cz(1, 1) = "参数不是数组"
    
11.         ChuiZu = cz
    
12.         Exit Function
    
13.     ElseIf j1 <> 3 Or j2 <> 2 Then
    
14.         cz(1, 1) = "参数必须是3行2列的数值数组"
    
15.         ChuiZu = cz
    
16.         Exit Function
    
17.     End If
    
18.     j1 = LBound(dd, 1)
    
19.     j2 = LBound(dd, 2)
    
20.     ReDim cz(j1 To UBound(dd, 1), j2 To UBound(dd, 2))
    
21.     For i = 0 To 2
    
22.         i1 = j1 + i Mod 3
    
23.         i2 = j1 + (i + 1) Mod 3
    
24.         i3 = j1 + (i + 2) Mod 3
    
25.         If dd(i2, j2) <> dd(i3, j2) And dd(i2, j2 + 1) <> dd(i3, j2 + 1) Then '横坐标、纵坐标均不相同
    
26.             k1 = (dd(i2, j2 + 1) - dd(i3, j2 + 1)) / (dd(i2, j2) - dd(i3, j2))
    
27.             b1 = (dd(i2, j2) * dd(i3, j2 + 1) - dd(i3, j2) * dd(i2, j2 + 1)) / (dd(i2, j2) - dd(i3, j2))
    
28.             k2 = -1 / k1
    
29.             b2 = dd(i1, j2 + 1) - k2 * dd(i1, j2)
    
30.             cz(i + j1, j2) = (b2 - b1) / (k1 - k2)
    
31.             cz(i + j1, j2 + 1) = k1 * cz(i + j1, j2) + b1
    
32.         ElseIf dd(i2, j2) = dd(i3, j2) And dd(i2, j2 + 1) <> dd(i3, j2 + 1) Then '横坐标相同、纵坐标不相同
    
33.             cz(i + j1, j2) = dd(i2, j2)
    
34.             cz(i + j1, j2 + 1) = dd(i1, j2 + 1)
    
35.         ElseIf dd(i2, j2) <> dd(i3, j2) And dd(i2, j2 + 1) = dd(i3, j2 + 1) Then '横坐标不相同、纵坐标相同
    
36.             cz(i + j1, j2) = dd(i1, j2)
    
37.             cz(i + j1, j2 + 1) = dd(i2, j2 + 1)
    
38.         Else '横坐标相同、纵坐标相同
    
39.             ReDim cz(1 To 1, 1 To 1)
    
40.             cz(1, 1) = "数据错误：两点重合"
    
41.             ChuiZu = cz
    
42.             Exit Function
    
43.         End If
    
44.     Next i
    
45.     If n = 0 Then
    
46.         ChuiZu = cz
    
47.     Else '垂心
    
48.         ChuiZu = ZhiXianJD(dd(j1, j2), dd(j1, j2 + 1), cz(j1, j2), cz(j1, j2 + 1), dd(j1 + 1, j2), dd(j1 + 1, j2 + 1), cz(j1 + 1, j2), cz(j1 + 1, j2 + 1))
    
49.     End If
    
50. End Function
    
51. Public Function ZhongDian(dd, Optional n% = 0) '2.根据三角形顶点坐标计算中点坐标（3*2下标相同）或返回重心、外心坐标（1*2）
    
52.     On Error Resume Next
    
53.     Dim i&, i2&, i3&, j1&, j2&
    
54.     If TypeName(dd) = "Range" Then dd = dd.Value
    
55.     j1 = UBound(dd, 1) - LBound(dd, 1) + 1
    
56.     j2 = UBound(dd, 2) - LBound(dd, 2) + 1
    
57.     ReDim zd(1 To 1, 1 To 1)
    
58.     If err.Number = 13 Then
    
59.         zd(1, 1) = "参数不是数组"
    
60.         ZhongDian = zd
    
61.         Exit Function
    
62.     ElseIf j1 <> 3 Or j2 <> 2 Then
    
63.         zd(1, 1) = "参数必须是3行2列的数值数组"
    
64.         ZhongDian = zd
    
65.         Exit Function
    
66.     End If
    
67.     j1 = LBound(dd, 1)
    
68.     j2 = LBound(dd, 2)
    
69.     ReDim zd(j1 To UBound(dd, 1), j2 To UBound(dd, 2))
    
70.     For i = 0 To 2
    
71.         i2 = j1 + (i + 1) Mod 3
    
72.         i3 = j1 + (i + 2) Mod 3
    
73.         If dd(i2, j2) = dd(i3, j2) And dd(i2, j2 + 1) = dd(i3, j2 + 1) Then '横坐标相同、纵坐标相同
    
74.             ReDim zd(1 To 1, 1 To 1)
    
75.             zd(1, 1) = "数据错误：两点重合"
    
76.             ZhongDian = zd
    
77.             Exit Function
    
78.         Else
    
79.             zd(i + j1, j2) = (dd(i2, j2) + dd(i3, j2)) / 2
    
80.             zd(i + j1, j2 + 1) = (dd(i2, j2 + 1) + dd(i3, j2 + 1)) / 2
    
81.         End If
    
82.     Next i
    
83.     If n = 0 Then
    
84.         ZhongDian = zd
    
85.     ElseIf n = 1 Then '重心
    
86.         ZhongDian = ZhiXianJD(dd(j1, j2), dd(j1, j2 + 1), zd(j1, j2), zd(j1, j2 + 1), dd(j1 + 1, j2), dd(j1 + 1, j2 + 1), zd(j1 + 1, j2), zd(j1 + 1, j2 + 1))
    
87.     Else '外心（相当于已知三点求圆心坐标）
    
88.         Dim a1#, b1#, c1#, a2#, b2#, c2#, wx(1 To 1, 1 To 2)
    
89.         a1 = 2 * (dd(j1, j2) - dd(j1 + 1, j2))
    
90.         b1 = 2 * (dd(j1, j2 + 1) - dd(j1 + 1, j2 + 1))
    
91.         c1 = dd(j1, j2) ^ 2 + dd(j1, j2 + 1) ^ 2 - dd(j1 + 1, j2) ^ 2 - dd(j1 + 1, j2 + 1) ^ 2
    
92.         a2 = 2 * (dd(j1, j2) - dd(j1 + 2, j2))
    
93.         b2 = 2 * (dd(j1, j2 + 1) - dd(j1 + 2, j2 + 1))
    
94.         c2 = dd(j1, j2) ^ 2 + dd(j1, j2 + 1) ^ 2 - dd(j1 + 2, j2) ^ 2 - dd(j1 + 2, j2 + 1) ^ 2
    
95.         wx(1, 1) = (b2 * c1 - b1 * c2) / (a1 * b2 - a2 * b1)
    
96.         wx(1, 2) = (a1 * c2 - a2 * c1) / (a1 * b2 - a2 * b1)
    
97.         ZhongDian = wx
    
98.     End If
    
99. End Function
    
100. Public Function JiaoFenDian(dd, Optional n% = 0) '3.根据三角形顶点坐标计算角分点坐标（3*2下标相同）或返回内心坐标（1*2）
     
101.     On Error Resume Next
     
102.     Dim i&, i1&, i2&, i3&, j1&, j2&, a#, b#, c#, m#
     
103.     If TypeName(dd) = "Range" Then dd = dd.Value
     
104.     j1 = UBound(dd, 1) - LBound(dd, 1) + 1
     
105.     j2 = UBound(dd, 2) - LBound(dd, 2) + 1
     
106.     ReDim jfd(1 To 1, 1 To 1)
     
107.     If err.Number = 13 Then
     
108.         jfd(1, 1) = "参数不是数组"
     
109.         JiaoFenDian = jfd
     
110.         Exit Function
     
111.     ElseIf j1 <> 3 Or j2 <> 2 Then
     
112.         jfd(1, 1) = "参数必须是3行2列的数值数组"
     
113.         JiaoFenDian = jfd
     
114.         Exit Function
     
115.     End If
     
116.     j1 = LBound(dd, 1)
     
117.     j2 = LBound(dd, 2)
     
118.     ReDim jfd(j1 To UBound(dd, 1), j2 To UBound(dd, 2))
     
119.     For i = 0 To 2
     
120.         i1 = j1 + i Mod 3
     
121.         i2 = j1 + (i + 1) Mod 3
     
122.         i3 = j1 + (i + 2) Mod 3
     
123.         If dd(i2, j2) = dd(i3, j2) And dd(i2, j2 + 1) = dd(i3, j2 + 1) Then '横坐标相同、纵坐标相同
     
124.             ReDim jfd(1 To 1, 1 To 1)
     
125.             jfd(1, 1) = "数据错误：两点重合"
     
126.             JiaoFenDian = jfd
     
127.             Exit Function
     
128.         Else
     
129.             a = ((dd(i2, j2) - dd(i1, j2)) ^ 2 + (dd(i2, j2 + 1) - dd(i1, j2 + 1)) ^ 2) ^ 0.5
     
130.             b = ((dd(i3, j2) - dd(i1, j2)) ^ 2 + (dd(i3, j2 + 1) - dd(i1, j2 + 1)) ^ 2) ^ 0.5
     
131.             c = ((dd(i3, j2) - dd(i2, j2)) ^ 2 + (dd(i3, j2 + 1) - dd(i2, j2 + 1)) ^ 2) ^ 0.5
     
132.             m = a / (a + b)
     
133.             jfd(i + j1, j2) = (dd(i3, j2) - dd(i2, j2)) * m + dd(i2, j2)
     
134.             jfd(i + j1, j2 + 1) = (dd(i3, j2 + 1) - dd(i2, j2 + 1)) * m + dd(i2, j2 + 1)
     
135.         End If
     
136.     Next i
     
137.     If n = 0 Then
     
138.         JiaoFenDian = jfd
     
139.     Else '内心
     
140.         JiaoFenDian = ZhiXianJD(dd(j1, j2), dd(j1, j2 + 1), jfd(j1, j2), jfd(j1, j2 + 1), dd(j1 + 1, j2), dd(j1 + 1, j2 + 1), jfd(j1 + 1, j2), jfd(j1 + 1, j2 + 1))
     
141.     End If
     
142. End Function
     
143. Public Function ZhouJieZhongDian(dd, Optional n% = 0) '4.根据三角形顶点坐标计算周界中点坐标（3*2下标相同）或返回界心坐标（1*2）
     
144.     On Error Resume Next
     
145.     Dim i&, i1&, i2&, i3&, j1&, j2&, a#, b#, c#, m#
     
146.     If TypeName(dd) = "Range" Then dd = dd.Value
     
147.     j1 = UBound(dd, 1) - LBound(dd, 1) + 1
     
148.     j2 = UBound(dd, 2) - LBound(dd, 2) + 1
     
149.     ReDim zjzd(1 To 1, 1 To 1)
     
150.     If err.Number = 13 Then
     
151.         zjzd(1, 1) = "参数不是数组"
     
152.         ZhouJieZhongDian = zjzd
     
153.         Exit Function
     
154.     ElseIf j1 <> 3 Or j2 <> 2 Then
     
155.         zjzd(1, 1) = "参数必须是3行2列的数值数组"
     
156.         ZhouJieZhongDian = zjzd
     
157.         Exit Function
     
158.     End If
     
159.     j1 = LBound(dd, 1)
     
160.     j2 = LBound(dd, 2)
     
161.     ReDim zjzd(j1 To UBound(dd, 1), j2 To UBound(dd, 2))
     
162.     For i = 0 To 2
     
163.         i1 = j1 + i Mod 3
     
164.         i2 = j1 + (i + 1) Mod 3
     
165.         i3 = j1 + (i + 2) Mod 3
     
166.         If dd(i2, j2) = dd(i3, j2) And dd(i2, j2 + 1) = dd(i3, j2 + 1) Then '横坐标相同、纵坐标相同
     
167.             ReDim zjzd(1 To 1, 1 To 1)
     
168.             zjzd(1, 1) = "数据错误：两点重合"
     
169.             ZhouJieZhongDian = zjzd
     
170.             Exit Function
     
171.         Else
     
172.             a = ((dd(i2, j2) - dd(i1, j2)) ^ 2 + (dd(i2, j2 + 1) - dd(i1, j2 + 1)) ^ 2) ^ 0.5
     
173.             b = ((dd(i3, j2) - dd(i1, j2)) ^ 2 + (dd(i3, j2 + 1) - dd(i1, j2 + 1)) ^ 2) ^ 0.5
     
174.             c = ((dd(i3, j2) - dd(i2, j2)) ^ 2 + (dd(i3, j2 + 1) - dd(i2, j2 + 1)) ^ 2) ^ 0.5
     
175.             m = (a + b + c) / 2 - a
     
176.             zjzd(i + j1, j2) = (dd(i3, j2) - dd(i2, j2)) * m / c + dd(i2, j2)
     
177.             zjzd(i + j1, j2 + 1) = (dd(i3, j2 + 1) - dd(i2, j2 + 1)) * m / c + dd(i2, j2 + 1)
     
178.         End If
     
179.     Next i
     
180.     If n = 0 Then
     
181.         ZhouJieZhongDian = zjzd
     
182.     Else '界心
     
183.         ZhouJieZhongDian = ZhiXianJD(dd(j1, j2), dd(j1, j2 + 1), zjzd(j1, j2), zjzd(j1, j2 + 1), dd(j1 + 1, j2), dd(j1 + 1, j2 + 1), zjzd(j1 + 1, j2), zjzd(j1 + 1, j2 + 1))
     
184.     End If
     
185. End Function

复制代码

其实：三角形还有“一心”，叫做“旁心”，这个旁心有三个，与本帖做的迭代“谢尔宾斯基三角形”主程序代码在思路上不一致，故而没做，以后有闲心的再补吧……

附件如下：

谢尔宾斯基三角形1.zip (218.96 KB, 下载次数: 13)

2020-2-12 22:50 上传

点击文件名下载附件

（附件更新至3楼说明，主要内容是：补充完整了三角形“六心”）

（这个附件耗时多日啊，是我的原创，不似前一个，只是为了验证一组“仿射变换”，本附件完全是从“迭代三角形”出发考虑的，关于迭代三角形还有很多有趣的问题，非发疯不足完成啊……）

aoe1981

二级自定义函数：

（顶楼字符数超限了）

1. Option Explicit
   
2. Public Function ZhiXianJD(x1, y1, x2, y2, x3, y3, x4, y4) '返回两直线交点坐标（坐标1、2确定第一条直线，坐标3、4确定第二条直线）
   
3.     Dim k1#, b1#, k2#, b2#, jd#(1 To 1, 1 To 2), pd As Boolean, err$
   
4.     pd = False: err = ""
   
5.     If x1 <> x2 Then k1 = (y2 - y1) / (x2 - x1): b1 = y1 - k1 * x1
   
6.     If x3 <> x4 Then k2 = (y4 - y3) / (x4 - x3): b2 = y3 - k2 * x3
   
7.     If x1 = x2 And y1 = y2 Then
   
8.         If x3 = x4 And y3 = y4 Then '点-点
   
9.             If x1 = x3 And y1 = y3 Then jd(1, 1) = x1: jd(1, 2) = y1: pd = True
   
10.         ElseIf x3 = x4 And y3 <> y4 Then '点-纵
    
11.             If x1 = x3 Then jd(1, 1) = x1: jd(1, 2) = y1: pd = True
    
12.         ElseIf x3 <> x4 And y3 = y4 Then '点-横
    
13.             If y1 = y3 Then jd(1, 1) = x1: jd(1, 2) = y1: pd = True
    
14.         ElseIf x3 <> x4 And y3 <> y4 Then '点-斜
    
15.             If y1 = k2 * x1 + b2 Then jd(1, 1) = x1: jd(1, 2) = y1: pd = True
    
16.         End If
    
17.     ElseIf x1 = x2 And y1 <> y2 Then
    
18.         If x3 = x4 And y3 = y4 Then '纵-点
    
19.             If x1 = x3 Then jd(1, 1) = x3: jd(1, 2) = y3: pd = True
    
20.         ElseIf x3 = x4 And y3 <> y4 Then '纵-纵
    
21.             If x1 = x3 Then err = "两垂直线重合"
    
22.         ElseIf x3 <> x4 And y3 = y4 Then '纵-横
    
23.             jd(1, 1) = x1: jd(1, 2) = y3: pd = True
    
24.         ElseIf x3 <> x4 And y3 <> y4 Then '纵-斜
    
25.             jd(1, 1) = x1: jd(1, 2) = k2 * jd(1, 1) + b2: pd = True
    
26.         End If
    
27.     ElseIf x1 <> x2 And y1 = y2 Then
    
28.         If x3 = x4 And y3 = y4 Then '横-点
    
29.             If y1 = y3 Then jd(1, 1) = x3: jd(1, 2) = y3: pd = True
    
30.         ElseIf x3 = x4 And y3 <> y4 Then '横-纵
    
31.             jd(1, 1) = x3: jd(1, 2) = y1: pd = True
    
32.         ElseIf x3 <> x4 And y3 = y4 Then '横-横
    
33.             If y1 = y3 Then err = "两水平线重合"
    
34.         ElseIf x3 <> x4 And y3 <> y4 Then '横-斜
    
35.             jd(1, 1) = (b1 - b2) / (k2 - k1): jd(1, 2) = k1 * jd(1, 1) + b1: pd = True
    
36.         End If
    
37.     ElseIf x1 <> x2 And y1 <> y2 Then
    
38.         If x3 = x4 And y3 = y4 Then '斜-点
    
39.             If y3 = k1 * x3 + b1 Then jd(1, 1) = x3: jd(1, 2) = y3: pd = True
    
40.         ElseIf x3 = x4 And y3 <> y4 Then '斜-纵
    
41.             jd(1, 1) = x3: jd(1, 2) = k1 * jd(1, 1) + b1: pd = True
    
42.         Else '斜-横、斜-斜
    
43.             If k1 = k2 And b1 = b2 Then
    
44.                 err = "两斜线重合"
    
45.             ElseIf k1 <> k2 Then
    
46.                 jd(1, 1) = (b1 - b2) / (k2 - k1): jd(1, 2) = k1 * jd(1, 1) + b1: pd = True
    
47.             End If
    
48.         End If
    
49.     End If
    
50.     If pd Then ZhiXianJD = jd Else If err = "" Then ZhiXianJD = "无交点" Else ZhiXianJD = err
    
51. End Function

复制代码

上面的一级自定义函数需要调用这个二级自定义函数，部分功能不可分割。

一级自定义函数可以部分单独使用：当返回三个坐标时；

二级自定义函数：旨在求两直线的交点坐标，完全可以单独使用，输入数据是8个，代表4个点坐标，1、2号点确定直线一，3、4号点确定直线二。

aoe1981

今天更新一下顶楼附件：我把“旁心”也做出来了。

自定义函数如下：

1. Public Function PangXin(dd) '5.根据三角形顶点坐标计算旁心坐标（3*2下标相同）
   
2.     On Error Resume Next
   
3.     Dim i&, i1&, i2&, i3&, j1&, j2&, a#, b#, c#
   
4.     If TypeName(dd) = "Range" Then dd = dd.Value
   
5.     j1 = UBound(dd, 1) - LBound(dd, 1) + 1
   
6.     j2 = UBound(dd, 2) - LBound(dd, 2) + 1
   
7.     ReDim px(1 To 1, 1 To 1)
   
8.     If err.Number = 13 Then
   
9.         px(1, 1) = "参数不是数组"
   
10.         PangXin = px
    
11.         Exit Function
    
12.     ElseIf j1 <> 3 Or j2 <> 2 Then
    
13.         px(1, 1) = "参数必须是3行2列的数值数组"
    
14.         PangXin = px
    
15.         Exit Function
    
16.     End If
    
17.     j1 = LBound(dd, 1)
    
18.     j2 = LBound(dd, 2)
    
19.     ReDim px(j1 To UBound(dd, 1), j2 To UBound(dd, 2))
    
20.     For i = 0 To 2
    
21.         i1 = j1 + i Mod 3
    
22.         i2 = j1 + (i + 1) Mod 3
    
23.         i3 = j1 + (i + 2) Mod 3
    
24.         If dd(i2, j2) = dd(i3, j2) And dd(i2, j2 + 1) = dd(i3, j2 + 1) Then '横坐标相同、纵坐标相同
    
25.             ReDim px(1 To 1, 1 To 1)
    
26.             px(1, 1) = "数据错误：两点重合"
    
27.             PangXin = px
    
28.             Exit Function
    
29.         Else
    
30.             a = ((dd(i3, j2) - dd(i2, j2)) ^ 2 + (dd(i3, j2 + 1) - dd(i2, j2 + 1)) ^ 2) ^ 0.5
    
31.             b = ((dd(i3, j2) - dd(i1, j2)) ^ 2 + (dd(i3, j2 + 1) - dd(i1, j2 + 1)) ^ 2) ^ 0.5
    
32.             c = ((dd(i2, j2) - dd(i1, j2)) ^ 2 + (dd(i2, j2 + 1) - dd(i1, j2 + 1)) ^ 2) ^ 0.5
    
33.             px(i + j1, j2) = (-a * dd(i1, j2) + b * dd(i2, j2) + c * dd(i3, j2)) / (-a + b + c)
    
34.             px(i + j1, j2 + 1) = (-a * dd(i1, j2 + 1) + b * dd(i2, j2 + 1) + c * dd(i3, j2 + 1)) / (-a + b + c)
    
35.         End If
    
36.     Next i
    
37.     PangXin = px
    
38. End Function

复制代码

计算公式如下：



效果图如下：




再补充几组进入“混沌”状态的迭代垂足三角形：







初始三角形若是直角三角形，迭代过程会停止。



只有当初始三角形是锐角三角形时，迭代垂足三角形才会生成漂亮的谢尔宾斯基三角形。如果初始三角形是钝角三角形，迭代后会进入混沌的状态。