2020-09-16

CAD图块顺序编号问题

 Type TEXT123           ''专为权设计   2019-8
    x As Double
    y As Double
    Quan As Double    '' 根据不同规则计算的权重
End Type

    Dim i, j, n, k, SP As Integer
    Dim MinX, MaxX, MinY, MaxY As Double      ''记录左上，右下范围
    Dim TempT As TEXT123
    Dim QENTITY() As TEXT123

Public Sub ADJ_Trail(SP As Integer, Q() As TEXT123)  ''邻近点追踪法 2020-9-14
   '' SP 为起始点，Q( )为点数组。
   Dim Temp As TEXT123
   Dim i, j, k, n, p As Integer
   Dim D1, D2 As Single
      
   n = UBound(Q)
   
   Q(SP).Quan = 0
   
   k = 1
   p = SP
   j = p
   
   While k < n
       D2 = 3.4E+38
       For i = 1 To n      ''找出最近的相邻点
            If Q(i).Quan = -1 Then
                D1 = Sqr((Q(i).x - Q(p).x) ^ 2 + (Q(i).y - Q(p).y) ^ 2)
                If D1 < D2 Then
                     j = i
                    D2 = D1
                End If
            End If
       Next i
       p = j
       Q(p).Quan = k
       k = k + 1
   Wend
   
End Sub

算法：从一个点出发，顺序追踪相邻点，就是找出与这个点p距离最近且未被使用（未赋权重值）的点作为下一个点，找出这个点后，进行权重赋值，如此循环，最终的效果就是线状追踪（若点的排列可以看作线状的）。

Public Function Quan_Gridz(ByVal x As Double, ByVal y As Double, ByVal MinX As Double, ByVal MaxX As Double, ByVal MinY As Double, ByVal MaxY As Double, ByVal n As Integer, ByVal a1 As Integer) As Double
   ''另一种权的计算方法，画格子，还是从左向右，从上向下  ,N 为总计个数，适用于不规则的形状。
   ''Z字形的方法,从左向右,然后从右向左,然后再从左向右,.......
   '' 增加一种功能，由用户指定行数，以应对不是方形，是线性的，一行，或一列 的情况
   Dim a, b As Integer
   Dim r, c As Double    ''行，列
   
    If a1 > 0 Then
       a = a1
   Else
       a = Int(Sqr(n))                    ''大致是方形 ， a*a个格子
   End If
      
   c = Abs(MaxX - MinX) / a      ''横向格子宽度
   r = Abs(MaxY - MinY) / a       ''纵向格子宽度
   
   b = Int((MaxY - y) / r)             ''行数
   If b Mod 2 = 0 Then
      Quan_Gridz = Int(((x - MinX) / c + b * a) * 10)
   Else
      Quan_Gridz = Int(((MaxX - x) / c + b * a) * 10)
   End If
End Function

而之字形赋值的基本思路是：画虚拟的方格网，判断点位于哪个格子内，然后按行列值计算权重（行的权重要大于列的权重）。上面的算法是计算某个点的权重。按如下方式调用 。

 For i = 1 To n
    QENTITY(i).Quan = Quan_Gridz(QENTITY(i).x, QENTITY(i).y, MinX, MaxX, MinY, MaxY, n, a1)
 Next i

计算权重之后，后面还有按权重排序，点的编号和其它信息在EXCEL表中，读取EXCEL表的内容，按权重顺序进行标注…不再赘述。
在上面的算法中还有一个关键问题需要解决：求出图块的左下角 和 右上角坐标，也即是 MinX， MaxX ， MinY， MaxY

 For Each acEnt In acSSet               ''遍历选择集实体
    
        acEnt.GetBoundingBox minPt, maxPt 
        x = (minPt(0) + maxPt(0)) / 2
        y = (minPt(1) + maxPt(1)) / 2
        
        If i = 1 Then MinX = x: MaxX = x: MinY = y: MaxY = y: SP = i
                
        QENTITY(i).x = x
        QENTITY(i).y = y
        QENTITY(i).Quan = -1               ''表示未被赋值
        
        If MinX > x Then MinX = x: SP = i
        If MaxY < y Then MaxY = y
        
        If MaxX < x Then MaxX = x
        If MinY > y Then MinY = y
        
         i = i + 1
         
   Next acEnt