ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: aoe1981

[已解决] 出个题:如何利用散点图,产生大量的随机点,使其落入给定多边形内?

[复制链接]

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:35 | 显示全部楼层
本帖最后由 aoe1981 于 2014-10-5 18:06 编辑

  不卖关子了,上附件:
   多边形随机点填充.rar (166.39 KB, 下载次数: 70)
  (已更新,增加了随机点重复检测……2014-10-05 18:05)

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:36 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  核心代码如下:
  1. Option Explicit
  2. Public Sub TianChong() '填充
  3. With 多边形
  4.     If .Range("a2").Value = "" Then MsgBox "请输入顶点数!", , "友情提示": Exit Sub
  5.     If Not (IsNumeric(.Range("a2").Value)) Then MsgBox "请输入数值!", , "友情提示": Exit Sub
  6.     If .Range("a14").Value = "" Then MsgBox "请输入随机点数!", , "友情提示": Exit Sub
  7.     If Not (IsNumeric(.Range("a2").Value)) Then MsgBox "请输入数值!", , "友情提示": Exit Sub
  8.     .Range("d18:e" & Rows.Count).ClearContents
  9.     Dim xx, yy, x#, y#, a#, b#, i&, j&, k&, n%, m&, xmin%, xmax%, ymin%, ymax%, sjd, t!
  10.     t = Timer: k = 0
  11.     n = .Range("a2").Value '顶点数
  12.     m = .Range("a14").Value '随机点数
  13.     xx = .Range("d2").Resize(n + 1)
  14.     yy = .Range("e2").Resize(n + 1)
  15.     xmin = WorksheetFunction.Min(xx): xmax = WorksheetFunction.Max(xx) '界定随机点产生的最大相关范围
  16.     ymin = WorksheetFunction.Min(yy): ymax = WorksheetFunction.Max(yy)
  17.     ReDim sjd(1 To m, 1 To 2) '存储符合要求的随机点
  18.     For j = 1 To m
  19. 100:
  20.         x = xmin + Rnd() * (xmax - xmin) '产生平面中的随机点
  21.         y = ymin + Rnd() * (ymax - ymin)
  22.         k = k + 1
  23.         For i = 1 To n
  24.             a = (x - xx(i, 1)) * (y - yy(i + 1, 1)) '计算叉积
  25.             b = (x - xx(i + 1, 1)) * (y - yy(i, 1))
  26.             If a - b <= 0 Then GoTo 100 '小于0时在多边形外,等于0在边上,大于0在内部
  27.         Next i
  28.         sjd(j, 1) = x: sjd(j, 2) = y
  29.     Next j
  30. .Range("d18").Resize(m, 2) = sjd
  31. End With
  32. MsgBox "共尝试落点" & k & "次,命中率:" & Format(m / k, "0.00%") & ",用时:" & Format(Timer - t, "0.0000") & "秒。", , "友情提示"
  33. End Sub
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:38 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:45 | 显示全部楼层
附件中的多边形的边数限制在:3~9,这对于直观演示来说,已经足够了……就是一个5边形,有时用坐标调节好,显示的差不多时,也是不太容易的……

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:50 | 显示全部楼层
  测试出了一个重大BUG:
   123.jpg

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:52 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:55 | 显示全部楼层
很明显,问题存在于凹多边形……凸多边形无此问题……
如此,得在算法上更加创新……可能这个方法将会异常复杂……

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 15:59 | 显示全部楼层
  尤其要注意的是,以下多边形会进入死循环,因为根据代码中的算法根本找不到一个符合要求的随机点!!!
  图如下:
   789.jpg

  对于这样的情况,一定要慎用!!!

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 16:06 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
如何解决上述BUG?
  一种可行的办法是:利用图形顶点的某种未知特性(至少对于我而言),事先排除凹多边形和交织多边形,从而只针对凸多边形进行随机点填充,这是回避问题的办法,但是,就“回避”本身而言,要做到这一点,也是需要很多知识与技巧的,也是需要深入研究的……

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-10-5 16:08 | 显示全部楼层
  当然,最好的设想是:不管是凸多边形、凹多边形还是交织多边形(最后一个是我起的名字,不知是否准确),都能在恰当的地方进行随机点填充……这是最佳境界……
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 10:33 , Processed in 0.043932 second(s), 7 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表