出个题：如何利用散点图，产生大量的随机点，使其落入给定多边形内？

aoe1981

　　喜讯、喜讯：
　　呵呵，开发成功了，无论是凸多边形，凹多边形，顺时针、逆时针，都可以进行填充了……
　　下面先上一组图。

aoe1981

aoe1981

　　上一个正式版1.0的附件：
　　 多边形随机点填充（正式版1.0）.rar (81.12 KB, 下载次数: 329)

2014-10-10 20:28 上传

点击文件名下载附件

aoe1981

　　正式版1.0的填充代码采用了更为通用的不同的算法，适应性更好，相关代码如下：

1. Public Sub TianChong1() '凹凸通用填充
   
2. With 多边形
   
3.     If .Range("a2").Value = "" Then MsgBox "请输入顶点数！", , "友情提示": Exit Sub
   
4.     If Not (IsNumeric(.Range("a2").Value)) Then MsgBox "请输入数值！", , "友情提示": Exit Sub
   
5.     If .Range("a14").Value = "" Then MsgBox "请输入随机点数！", , "友情提示": Exit Sub
   
6.     If Not (IsNumeric(.Range("a2").Value)) Then MsgBox "请输入数值！", , "友情提示": Exit Sub
   
7.     .Range("d18:e" & Rows.Count).ClearContents
   
8.     Dim xx, yy, x#, y#, X1#, Y1#, X2#, Y2#, a#, b#, i&, j&, k&, n%, m&, xmin#, xmax#, ymin#, ymax#, sjd, t!
   
9.     Dim ddxmin#, ddxmax#, ddymin#, ddymax#, jds%, jdx# '交点数
   
10.     n = .Range("a2").Value '顶点数
    
11.     m = .Range("a14").Value '随机点数
    
12.     xx = .Range("d2").Resize(n + 1)
    
13.     yy = .Range("e2").Resize(n + 1)
    
14.     Call DuoBianXing(xx, yy, n)
    
15.     t = Timer: k = 0
    
16.     xmin = WorksheetFunction.Min(xx): xmax = WorksheetFunction.Max(xx) '界定随机点产生的最大相关范围
    
17.     ymin = WorksheetFunction.Min(yy): ymax = WorksheetFunction.Max(yy)
    
18.     ReDim sjd(1 To m, 1 To 2) '存储符合要求的随机点
    
19.     j = 0
    
20.     Do While j < m
    
21. 100:
    
22.         x = xmin + Rnd() * (xmax - xmin) '产生平面中的随机点
    
23.         y = ymin + Rnd() * (ymax - ymin)
    
24.         jds = 0
    
25.         k = k + 1
    
26.         For i = 1 To n
    
27.             X1 = xx(i, 1): Y1 = yy(i, 1)
    
28.             X2 = xx(i + 1, 1): Y2 = yy(i + 1, 1)
    
29.             If X1 < X2 Then
    
30.                 ddxmin = X1: ddxmax = X2
    
31.             Else
    
32.                 ddxmin = X2: ddxmax = X1
    
33.             End If
    
34.             If Y1 < Y2 Then
    
35.                 ddymin = Y1: ddymax = Y2
    
36.             Else
    
37.                 ddymin = Y2: ddymax = Y1
    
38.             End If
    
39.             If X1 = X2 And Y1 <> Y2 Then '边的方程为x=a时（垂直）
    
40.                 If x > X1 And y > ddymin And y < ddymax Then jds = jds + 1
    
41.             ElseIf X1 <> X2 And Y1 <> Y2 Then '边的方程为y=ax+b时（倾斜）
    
42.                 If x > ddxmin And y > ddymin And y < ddymax Then
    
43.                     a = (Y2 - Y1) / (X2 - X1): b = (Y1 * X2 - Y2 * X1) / (X2 - X1) '边的斜率、纵截距
    
44.                     jdx = (y - b) / a '交点横坐标
    
45.                     If jdx < x Then jds = jds + 1 '交点在随机点的左侧时，因为是水平向左的射线
    
46.                 End If
    
47.                 '由于显示的特点，忽略随机点纵坐标等于顶点纵坐标的情况
    
48.             ElseIf X1 <> X2 And Y1 = Y2 Then '边的方程为y=b时（水平）
    
49.                 '由于显示的特点，忽略随机点纵坐标等于顶点纵坐标的情况
    
50.             End If
    
51.         Next i
    
52.         If jds Mod 2 = 1 Then j = j + 1: sjd(j, 1) = x: sjd(j, 2) = y
    
53.     Loop
    
54. .Range("d18").Resize(m, 2) = sjd
    
55. End With
    
56. MsgBox "共尝试落点" & k & "次，命中率：" & Format(m / k, "0.00%") & "，用时：" & Format(Timer - t, "0.0000") & "秒。", , "友情提示"
    
57. End Sub

复制代码

aoe1981

　　粘贴几组测试顶点坐标：

9个顶点			4个顶点
1	3		-2	1
8	1		8	1
9	8		6	-9
4	9		2	-9
4	6
-4	9
-7	5
1	6
-5	-2

4个顶点			4个顶点
-2	1		1	1
8	1		9	1
6	-9		9	6
4	-2		1	6

aoe1981

必要的说明：
细心的人会发现，我在54楼的代码有两种情况其实没有写，忽略了……呵呵
这也是我称呼为“正式版1.0”的原因：是可以凑合着用了，但是不是十分完善……

aoe1981

54楼代码的核心算理如下：
http://blog.csdn.net/zuihoudebingwen/article/details/7968843
相关部分：
“水平/垂直交叉点数判别法（适用于任意多边形包括凹凸边形）
注意到如果从P作水平向左的射线的话，如果P在多边形内部，那么这条射线与多边形的交点必为奇数，如果P在多边形外部，则交点个数必为偶数（0也在内）。所以，我们可以顺序考虑多边形的每条边，求出交点的总个数。还有一些特殊情况要考虑……”



我忽略的正是特殊情况……

aoe1981

　　为什么我忽略了特殊情况，却可以得到不错的效果呢？
　　首先，所谓特殊情况即是随机点向左的水平射线恰好经过多边形顶点的情况，此时，交点会被计算两次，不会产生奇数的情况，应当特殊处理，我想到的办法是：向右上偏移很小一个度数，绕过这个点即可，但是代码将很是冗长、复杂；
　　其次，为何忽略，一是测试基本代码是否能正常运行，二才是意外发现，想了想，原因在于屏幕显示，散点图的每一个点最小像素是2，特殊情况不处理的话，多边形顶点所在水平线上是不会落有填充点的，也就是说，在内部会有一些水平线（未填充的）出现，但是没有，估计就是显示时2像素把“邻居”给挤满的缘故吧……
　　呵呵……
　　其实，还有个原因，就是我的坐标轴限定最大最小为10和－10，这也是一个人为原因……

　　呵呵，以后有功夫了，再完善，说不定来个“正式版2.0”，不过，从显示效果上来说，可能差别不大……

香川群子

已知多边形n个点的坐标，就可以直接画出闭合图形，然后当然就可以任意改变这个图形的颜色属性。

Sub Macro1()
'
' Macro1 Macro
' 宏由 User 录制，时间: 2014-10-10
'

'
    With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 232.5, 127.5)
        .AddNodes msoSegmentLine, msoEditingAuto, 345.75, 128.25
        .AddNodes msoSegmentLine, msoEditingAuto, 384.75, 207#
        .AddNodes msoSegmentLine, msoEditingAuto, 282.75, 291#
        .AddNodes msoSegmentLine, msoEditingAuto, 309.75, 218.25
        .AddNodes msoSegmentLine, msoEditingAuto, 175.5, 198.75
        .AddNodes msoSegmentLine, msoEditingAuto, 313.5, 189#
        .AddNodes msoSegmentLine, msoEditingAuto, 178.5, 165#
        .AddNodes msoSegmentLine, msoEditingAuto, 269.5, 154.5
        .AddNodes msoSegmentLine, msoEditingAuto, 232.5, 127.5
        .ConvertToShape.Select
    End With
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 13
End Sub

aoe1981

香川群子 发表于 2014-10-10 22:20
已知多边形n个点的坐标，就可以直接画出闭合图形，然后当然就可以任意改变这个图形的颜色属性。

Sub Mac ...

看来，我这是舍近求远了……自个给自个下了一个套……
不过，复习了许多关于多边形以及平面向量的知识……
呵呵……
多谢您指点……