请高手帮忙优化一下，用到了zzyong00版主的判断曲线内外函数

yswoyh

请高手帮忙优化一下，用到了zzyong00版主的判断曲线内外函数，运行速度超慢
Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Const VK_ESCAPE = &H1B
Private Const acSelectionSetLast = 4
Private Declare Function SetWindowPos Lib "user32" (ByVal HWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Dim Acadapp As Object
Dim acaddoc As Object

Sub zbtc()    '主程序
     Dim ESC As Long
     GetAsyncKeyState VK_ESCAPE
     On Error GoTo Err_Control
     Dim entry As Object
     Dim a As Long
     Dim b As Long
     Dim Pt1, Pt2 As Variant
     Dim ibpt As Variant
     Dim ibpt1(0 To 2) As Double
     Dim ibpt2(0 To 2) As Double
     Dim i, n As Integer
     Dim ib As Object
     Dim ib1 As Object      '定义插入图块
     Dim ib_st As String    '定义插入图块的路径
     Dim x, y As Integer    '定义纵向横向循环
     Dim blc As Integer     '定义比例尺
     Dim varCancel As Variant

     Dim StartT As Long  '获取运算开始时间
     Dim SpendT As Long  '获取运算结束时间
     StartT = GetTickCount
     blc = 10

     Set Acadapp = GetObject(, "AutoCAD.application")
     Set acaddoc = Acadapp.ActiveDocument

     Acadapp.ActiveDocument.Utility.GetEntity entry, "选择一个多边形:"     '提示用户选择一个图形
     entry.GetBoundingBox Pt1, Pt2                                         '计算最大与最小坐标值
     ibpt = Rectang(Pt1, Pt2)                                              '将最大外边坐标值保存在内存中

     x = Int((ibpt(8) - ibpt(2)) / blc + 1)                                                           '计算纵向循环次数
     y = Int((ibpt(3) - ibpt(1)) / blc + 1)                                                           '计算横向循环次数
     ib_st = "C:\123.dwg"                                                                             '取得插入块的路径
     ibpt1(0) = ibpt(1): ibpt1(1) = ibpt(2)                                                           '获取第一个插入点的坐标
     ibpt2(0) = ibpt(1) + (blc / 2): ibpt2(1) = ibpt(2) + (blc / 2)                                   '获取第二个插入点的坐标

    For i = 1 To x
        For n = 1 To y
            a = InOutside(entry, ibpt1)
            If a < 0 And n > 1 Then
                Set ib = acaddoc.ModelSpace.InsertBlock(ibpt1, ib_st, 1, 1, 1, 0, 1)          '第一行数据
            Else
            End If
            b = InOutside(entry, ibpt2)
            If b < 0 Then
                Set ib1 = acaddoc.ModelSpace.InsertBlock(ibpt2, ib_st, 1, 1, 1, 0, 1)         '第二行数据
            Else
            End If

            ibpt1(0) = ibpt1(0) + blc
            ibpt2(0) = ibpt2(0) + blc
        Next n
            ibpt1(1) = ibpt1(1) + blc
            ibpt2(1) = ibpt2(1) + blc
            ibpt1(0) = Pt1(0)
            ibpt2(0) = Pt1(0) + (blc / 2)
    Next i
    SpendT = GetTickCount - StartT
    acaddoc.Utility.Prompt ("本次操作耗时:" & Format(SpendT / 1000, "0.00") & "秒")
Exit_Here:
    Exit Sub
Err_Control:
     varCancel = acaddoc.GetVariable("LASTPROMPT")
     ESC = GetAsyncKeyState(VK_ESCAPE)
     Select Case Err.Number               '按了取消键或其它透明命令
         Case -2147352567                 '如果命令行提示中没有“取消”这样的文字出现 一般来说在2002中按了回车或空格都不会出现“取消” 则退出
             If InStr(1, varCancel, "*Cancel*") <> 0 And InStr(1, varCancel, "*取消*") <> 0 Then
                 Err.Clear
                 Resume Exit_Here
             ElseIf ESC <> 0 Then         '如果按了ESC键，则退出
                 Err.Clear
                 Resume Exit_Here
             Else                         '其它情况下，则恢复。如选择了透明命令，则会出现“取消” 字样，但不是按了“取消”键。
                 Err.Clear
                 Resume Exit_Here
             End If
         Case -2147467259, -2145320928     '右键单击或回车或空格。在这里，-2147467259用于AutoCAD 2000 及2002，而-2145320928为2004专用
             Err.Clear
             Resume Exit_Here
         Case Else                         '其它情况，一律退出
             Err.Clear
             Resume Exit_Here
     End Select
End Sub



'下面是用到的模块模块
Dim Acadapp As Object
Dim acaddoc As Object
'在模块中添加以下代码
Public Enum InOut
    Inside = -1
    Outside = 1
End Enum

Function InOutside(pl As Object, P1 As Variant) As Long
    'PL是要标注的PL线，P1是要监测是否在曲线内的点，三维DOUBLE数组
    '判断标注位置是否在PL范围内，可以设定坐标标在范围内还是外面
    'intInOut=-1是内侧，intInOut＝1是外侧,intInOut=0是不确定是内还是外
    Set Acadapp = GetObject(, "autocad.application")
    Set acaddoc = Acadapp.ActiveDocument

    Dim Ppl   As Variant
    Dim tmpPL As Object
    Dim i As Integer
    Set tmpPL = pl.Copy

    tmpPL.Closed = True
    tmpPL.Elevation = 0
    Ppl = tmpPL.Coordinates
    Dim dblYmax As Double                                                       'Y坐标最大值
    dblYmax = Ppl(1)
    For i = 3 To UBound(Ppl) Step 2
        If dblYmax < Ppl(i) Then dblYmax = Ppl(i)
    Next i
    Dim tmpP(2) As Double                                                       '临时点
    tmpP(0) = P1(0)
    tmpP(1) = dblYmax + 100
    tmpP(2) = 0
    Dim objL As Object
    Set objL = acaddoc.ModelSpace.AddLine(P1, tmpP)

    'ZoomAll
    Dim dblPoints As Variant
    dblPoints = objL.IntersectWith(tmpPL, acExtendNone)
    tmpPL.Delete
    objL.Delete                                                                 '清理战场
    'Debug.Print VarType(dblPoints) '即使没有交点，也是一个空的三维数组
    If UBound(dblPoints) = -1 Then
        InOutside = Outside
        Exit Function
    End If
    If ((UBound(dblPoints) - LBound(dblPoints) + 1) / 3) Mod 2 Then             '交点个数为奇数，就在内侧；为偶数，就在外侧
        InOutside = Inside
    Else
        InOutside = Outside
    End If
    'Debug.Print InOutside
End Function

Function Rectang(sp As Variant, ep As Variant) As Double()
    '========================
    '画矩形函数，返回一个数组
    '
    '调用Rectang（第一点,第二点)
    '============================
    On Error GoTo ESC
    d = Sqr((sp(1) - ep(1)) ^ 2 + (sp(0) - ep(0)) ^ 2)
    Dim p(1 To 8) As Double '用来放多段线点数组
    p(1) = sp(0)
    p(2) = sp(1)                    '第一点

    p(3) = ep(0) - sp(0) + sp(0)
    p(4) = sp(1)                    '第二点

    p(5) = ep(0)
    p(6) = ep(1)                    '第三点

    p(7) = sp(0)
    p(8) = ep(1) - sp(1) + sp(1)    '第四点
    Rectang = p
ESC:
    If Err Then MsgBoxErr.Description , vbOKOnly, "错误"
End Function

chixun99

直接使用cad文件本身内部的块来插入，速度并不慢。关键是读取外部块文件的时间会比较多，比较好的方式是第一次运行时把外部块插入到图形中，代码中的块名改为内部块名就蛮快的了，不需要反复读取外部文件。
  ib_st = "C:\123.dwg"……  改为 ib_st = "123"                                                                             '取得插入块的名称

chixun99

另外对原代码作者的作品有疑问最好去原贴咨询。避免讨论别人作品。

yswoyh

chixun99 发表于 2022-4-14 11:45
另外对原代码作者的作品有疑问最好去原贴咨询。避免讨论别人作品。

欠考虑了多谢

zzyong00

这种判断点是否在曲线内的方法，是真的在cad中画出了直线，求交点，又删除直线，操作很多，是确比较慢，采用纯计算的方法会比较快，但对于复杂曲线，计算也是比较麻烦的

yswoyh

zzyong00 发表于 2022-5-31 15:24
这种判断点是否在曲线内的方法，是真的在cad中画出了直线，求交点，又删除直线，操作很多，是确比较慢，采 ...

对于判断spline的多边形是不是需要转换一下之后才能操作，转换后的多边形的坐标集就会很大，不知道别人多边形叠加怎么处理的

zzyong00

yswoyh 发表于 2022-6-2 09:35
对于判断spline的多边形是不是需要转换一下之后才能操作，转换后的多边形的坐标集就会很大，不知道别人多 ...

用这个方法是不用转换的，cad内置曲线都可以的。不过你可能得针对spline修改一下代码