作了几个程序

chtd

Sub sdxc() '-------------------------删线上点(一定距离范围内)
Call pdxu
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim gpcode1(0) As Integer
Dim datavalue1(0) As Variant
Dim groupCode As Variant, dataCode As Variant
Dim groupCode1 As Variant, dataCode1 As Variant
Dim mysel2 As AcadSelectionSet
Dim mysel As AcadSelectionSet
Dim mysel1 As AcadSelectionSet
Dim lyr As AcadLayer
Dim ersa As Boolean
ersa = False
gpCode(0) = 8
dataValue(0) = "xzb"
groupCode = gpCode
dataCode = dataValue

gpcode1(0) = 8
datavalue1(0) = "szh"
groupCode1 = gpcode1
dataCode1 = datavalue1
If ThisDrawing.SelectionSets.count = 0 Then
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
mysel.Select acSelectionSetAll, , , groupCode, dataCode
Set mysel1 = ThisDrawing.SelectionSets.Add("mysel1")
mysel1.Select acSelectionSetAll, , , groupCode1, dataCode1
Else
For Each xusel In ThisDrawing.SelectionSets
xusel.Delete
Next
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
mysel.Select acSelectionSetAll, , , groupCode, dataCode
Set mysel1 = ThisDrawing.SelectionSets.Add("mysel1")
mysel1.Select acSelectionSetAll, , , groupCode1, dataCode1
End If

On Error GoTo re
cx = ThisDrawing.Utility.GetString(0, "请输入限差:")

Dim zuob(0 To 35) As Double

Dim z1 As Variant

Set lyr = ThisDrawing.Layers.Add("查线上点")
ThisDrawing.ActiveLayer = lyr

If cx <> "" Then

For Each selentity In mysel
    If selentity.EntityType = acPoint Then
       z1 = selentity.Coordinates
       z1(0) = z1(0): z1(1) = z1(1): z1(2) = 0
       R = Val(cx)
       z1(0) = z1(0): z1(1) = z1(1): z1(2) = 0
       zuob(0) = z1(0) - R / 6 * 6: zuob(1) = z1(1): zuob(2) = 0
       zuob(3) = z1(0) - R / 6 * 5.196: zuob(4) = z1(1) + R / 6 * 3: zuob(5) = 0
       zuob(6) = z1(0) - R / 6 * 3: zuob(7) = z1(1) + R / 6 * 5.196: zuob(8) = 0
       zuob(9) = z1(0): zuob(10) = z1(1) + R / 6 * 6: zuob(11) = 0
       zuob(12) = z1(0) + R / 6 * 3: zuob(13) = z1(1) + R / 6 * 5.196: zuob(14) = 0
       zuob(15) = z1(0) + R / 6 * 5.196: zuob(16) = z1(1) + R / 6 * 3: zuob(17) = 0
       zuob(18) = z1(0) + R / 6 * 6: zuob(19) = z1(1): zuob(20) = 0
       zuob(21) = z1(0) + R / 6 * 5.196: zuob(22) = z1(1) - R / 6 * 3: zuob(23) = 0
       zuob(24) = z1(0) + R / 6 * 3: zuob(25) = z1(1) - R / 6 * 5.196: zuob(26) = 0
       zuob(27) = z1(0): zuob(28) = z1(1) - R / 6 * 6: zuob(29) = 0
       zuob(30) = z1(0) - R / 6 * 3: zuob(31) = z1(1) - R / 6 * 5.196: zuob(32) = 0
       zuob(33) = z1(0) - R / 6 * 5.196: zuob(34) = z1(1) - R / 6 * 3: zuob(35) = 0
       Set mysel2 = ThisDrawing.SelectionSets.Add("mysel2")

       mysel2.SelectByPolygon acSelectionSetCrossingPolygon, zuob
      
       If mysel2.count > 0 Then
          For Each ss In mysel2
              If ss.EntityType = 2 Or ss.EntityType = 24 Then
                 ersa = True
                 Exit For
              End If
          Next
       End If
      
       If ersa = True Then
          selentity.Delete
       End If
       ersa = False
       mysel2.Delete
    End If
   
Next
End If
MsgBox "ok"
re:
   mysel.Delete
   mysel1.Delete
End Sub

 

上善若水！@#

你好，那个加载了lsp后提示no function definition: CENTSEL是怎么回事，有解决方法不

chtd

Sub dxlj()‘-------------------------------多线连接
Dim zuobiao As Variant
Dim zuobiao1 As Variant
Dim xuln As AcadLWPolyline
On Error GoTo we

Dim mysel As AcadSelectionSet
If ThisDrawing.SelectionSets.count = 0 Then
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
mysel.SelectOnScreen
Else
ThisDrawing.SelectionSets.Item(0).Delete
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
mysel.SelectOnScreen
End If

If mysel.count = 2 Then
Dim minn As Integer
Dim minn1 As Integer
If mysel(0).EntityType = 24 And mysel(1).EntityType = 24 Then
zuobiao = mysel(0).Coordinates
zuobiao1 = mysel(1).Coordinates
minn = UBound(zuobiao)
minn1 = UBound(zuobiao1)

ReDim zuobb(0 To minn + minn1 + 1) As Double

If Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(UBound(zuobiao1))) ^ 2) And Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) Then
For i = 0 To minn
   zuobb(i) = zuobiao(i)
Next

For i = 0 To minn1
   zuobb(i + minn + 1) = zuobiao1(i)
Next

ElseIf Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(UBound(zuobiao1))) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(1)) ^ 2) And Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(UBound(zuobiao1))) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1))) ^ 2) Then
For i = 0 To minn
   zuobb(i) = zuobiao(i)
Next

For i = 0 To minn1 Step 2
   zuobb(i + minn + 1) = zuobiao1(minn1 - i - 1)
   zuobb(i + minn + 2) = zuobiao1(minn1 - i)
Next

ElseIf Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1))) ^ 2) And Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(1)) ^ 2) Then
For i = 0 To minn Step 2
   zuobb(i) = zuobiao(minn - i - 1)
   zuobb(i + 1) = zuobiao(minn - i)
Next

For i = 0 To minn1
   zuobb(i + minn + 1) = zuobiao1(i)
Next

ElseIf Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1))) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) And Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1))) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2 + (zuobiao(UBound(zuobiao)) - zuobiao1(UBound(zuobiao1))) ^ 2) Then

For i = 0 To minn Step 2
   zuobb(i) = zuobiao(minn - i - 1)
   zuobb(i + 1) = zuobiao(minn - i)
Next

For i = 0 To minn1 Step 2
   zuobb(i + minn + 1) = zuobiao1(minn1 - i - 1)
   zuobb(i + minn + 2) = zuobiao1(minn1 - i)
Next

End If
ThisDrawing.ActiveLayer = ThisDrawing.Layers(mysel(0).Layer)

Set xuln = ThisDrawing.ModelSpace.AddLightWeightPolyline(zuobb)
xuln.Elevation = mysel(0).Elevation
xuln.Thickness = mysel(0).Thickness
xuln.ConstantWidth = mysel(0).ConstantWidth
xuln.Linetype = mysel(0).Linetype
xuln.color = mysel(0).color
xuln.Lineweight = mysel(0).Lineweight
mysel(0).Delete
mysel(1).Delete
ElseIf mysel(0).EntityType = 2 And mysel(1).EntityType = 2 Then
zuobiao = mysel(0).Coordinates
zuobiao1 = mysel(1).Coordinates
minn = UBound(zuobiao)
minn1 = UBound(zuobiao1)

ReDim zuobb(0 To minn + minn1 + 1) As Double
If Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) And Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) Then
For i = 0 To minn
   zuobb(i) = zuobiao(i)
Next

For i = 0 To minn1
   zuobb(i + minn + 1) = zuobiao1(i)
Next
ElseIf Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) And Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) Then
For i = 0 To minn
   zuobb(i) = zuobiao(i)
Next

For i = 0 To minn1 Step 3
   zuobb(i + minn + 1) = zuobiao1(minn1 - i - 2)
   zuobb(i + minn + 2) = zuobiao1(minn1 - i - 1)
   zuobb(i + minn + 3) = zuobiao1(minn1 - i)
Next
ElseIf Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) And Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) Then
For i = 0 To minn Step 3
   zuobb(i) = zuobiao(minn - i - 2)
   zuobb(i + 1) = zuobiao(minn - i - 1)
   zuobb(i + 2) = zuobiao(minn - i)
Next

For i = 0 To minn1
   zuobb(i + minn + 1) = zuobiao1(i)
Next

ElseIf Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) And Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) Then

For i = 0 To minn Step 3
   zuobb(i) = zuobiao(minn - i - 2)
   zuobb(i + 1) = zuobiao(minn - i - 1)
   zuobb(i + 2) = zuobiao(minn - i)
Next

For i = 0 To minn1 Step 3
   zuobb(i + minn + 1) = zuobiao1(minn1 - i - 2)
   zuobb(i + minn + 2) = zuobiao1(minn1 - i - 1)
   zuobb(i + minn + 3) = zuobiao1(minn1 - i)
Next

End If
ThisDrawing.ActiveLayer = ThisDrawing.Layers(mysel(0).Layer)
mysel(0).Delete
mysel(1).Delete
ThisDrawing.ModelSpace.Add3DPoly zuobb

ElseIf mysel(0).EntityType = 23 And mysel(1).EntityType = 23 Then
zuobiao = mysel(0).Coordinates
zuobiao1 = mysel(1).Coordinates
minn = UBound(zuobiao)
minn1 = UBound(zuobiao1)

ReDim zuobb(0 To minn + minn1 + 1) As Double
If Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) And Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) Then
For i = 0 To minn
   zuobb(i) = zuobiao(i)
Next

For i = 0 To minn1
   zuobb(i + minn + 1) = zuobiao1(i)
Next
ElseIf Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) And Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) Then
For i = 0 To minn
   zuobb(i) = zuobiao(i)
Next

For i = 0 To minn1 Step 3
   zuobb(i + minn + 1) = zuobiao1(minn1 - i - 2)
   zuobb(i + minn + 2) = zuobiao1(minn1 - i - 1)
   zuobb(i + minn + 3) = zuobiao1(minn1 - i)
Next
ElseIf Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) And Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(0)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(1)) ^ 2) Then
For i = 0 To minn Step 3
   zuobb(i) = zuobiao(minn - i - 2)
   zuobb(i + 1) = zuobiao(minn - i - 1)
   zuobb(i + 2) = zuobiao(minn - i)
Next

For i = 0 To minn1
   zuobb(i + minn + 1) = zuobiao1(i)
Next

ElseIf Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(0) - zuobiao1(0)) ^ 2 + (zuobiao(1) - zuobiao1(1)) ^ 2) And Sqr((zuobiao(0) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) _
< Sqr((zuobiao(UBound(zuobiao) - 2) - zuobiao1(UBound(zuobiao1) - 2)) ^ 2 + (zuobiao(UBound(zuobiao) - 1) - zuobiao1(UBound(zuobiao1) - 1)) ^ 2) Then

For i = 0 To minn Step 3
   zuobb(i) = zuobiao(minn - i - 2)
   zuobb(i + 1) = zuobiao(minn - i - 1)
   zuobb(i + 2) = zuobiao(minn - i)
Next

For i = 0 To minn1 Step 3
   zuobb(i + minn + 1) = zuobiao1(minn1 - i - 2)
   zuobb(i + minn + 2) = zuobiao1(minn1 - i - 1)
   zuobb(i + minn + 3) = zuobiao1(minn1 - i)
Next

End If
ThisDrawing.ActiveLayer = ThisDrawing.Layers(mysel(0).Layer)
Set xuln = ThisDrawing.ModelSpace.AddPolyline(zuobb)
xuln.Thickness = mysel(0).Thickness
xuln.ConstantWidth = mysel(0).ConstantWidth
xuln.Linetype = mysel(0).Linetype
xuln.color = mysel(0).color
xuln.Lineweight = mysel(0).Lineweight
mysel(0).Delete
mysel(1).Delete
End If
Else
MsgBox "此方法限于两根线"
End If
If mysel.count <> 0 Then
mysel.Delete
End If
we:
End Sub

chtd

Sub jbgh()‘-------------------------------曲线局部光滑
On Error GoTo we
Dim bzuo As Variant
Dim mysel As AcadSelectionSet
If ThisDrawing.SelectionSets.count = 0 Then
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
mysel.SelectOnScreen
Else
ThisDrawing.SelectionSets.Item(0).Delete
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
mysel.SelectOnScreen
End If

ThisDrawing.ActiveLayer = ThisDrawing.Layers(mysel(0).Layer)
ThisDrawing.SetVariable "OSMODE", 512
'strs = ThisDrawing.Utility.GetString(0, "请输入线上每两点之间内插点的个数:")
add1 = ThisDrawing.Utility.GetPoint(, "请输入起点:")
add2 = ThisDrawing.Utility.GetPoint(add1, "请输入终点:")
If mysel.count = 1 Then
If mysel(0).EntityType = 2 Then '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>三维线
bzuo = mysel(0).Coordinates
For i = 0 To UBound(bzuo) - 3 Step 3
    dis1 = Sqr((bzuo(i) - bzuo(i + 3)) ^ 2 + (bzuo(i + 1) - bzuo(i + 4)) ^ 2)
    dis2 = Sqr((bzuo(i) - add1(0)) ^ 2 + (bzuo(i + 1) - add1(1)) ^ 2) + Sqr((bzuo(i + 3) - add1(0)) ^ 2 + (bzuo(i + 4) - add1(1)) ^ 2)
    If dis2 - dis1 <= 0.01 Then
       m = (i + 3) / 3
    End If
    dis1 = Sqr((bzuo(i) - bzuo(i + 3)) ^ 2 + (bzuo(i + 1) - bzuo(i + 4)) ^ 2)
    dis2 = Sqr((bzuo(i) - add2(0)) ^ 2 + (bzuo(i + 1) - add2(1)) ^ 2) + Sqr((bzuo(i + 3) - add2(0)) ^ 2 + (bzuo(i + 4) - add2(1)) ^ 2)
    If dis2 - dis1 <= 0.01 Then
       n = (i + 3) / 3
    End If
Next

ReDim zuob(0 To (Val(strs) * (Abs(m - n) + 1)) * 3 + 3 * ((UBound(bzuo) + 1) / 3 - Abs(m - n) - 2) - 1) As Double
If m > n Then
   lk = 0
   For j = 0 To UBound(bzuo) Step 3
       If j / 3 + 1 < n Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1): zuob(lk + 2) = bzuo(j + 2)
          lk = lk + 3
       ElseIf j / 3 + 1 >= n And j / 3 + 1 <= m Then
          For ll = 0 To strs - 1
          zuob(lk) = (ll + 1) * (bzuo((j + 3)) - bzuo(j)) / (strs + 1) + bzuo(j)
          zuob(lk + 1) = (ll + 1) * (bzuo(j + 4) - bzuo(j + 1)) / (strs + 1) + bzuo(j + 1)
          zuob(lk + 2) = (ll + 1) * (bzuo(j + 5) - bzuo(j + 2)) / (strs + 1) + bzuo(j + 2)
          lk = lk + 3
          Next
       ElseIf j / 3 + 1 > m + 1 Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1): zuob(lk + 2) = bzuo(j + 2)
          lk = lk + 3
       End If
   Next

ElseIf n > m Then
  lk = 0
   For j = 0 To UBound(bzuo) Step 3
       If j / 3 + 1 < m Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1): zuob(lk + 2) = bzuo(j + 2)
          lk = lk + 3
       ElseIf j / 3 + 1 >= m And (j + 1) / 3 <= n Then
          For ll = 0 To strs - 1
          zuob(lk) = (ll + 1) * (bzuo((j + 3)) - bzuo(j)) / (strs + 1) + bzuo(j)
          zuob(lk + 1) = (ll + 1) * (bzuo(j + 4) - bzuo(j + 1)) / (strs + 1) + bzuo(j + 1)
          zuob(lk + 2) = (ll + 1) * (bzuo(j + 5) - bzuo(j + 2)) / (strs + 1) + bzuo(j + 2)
          lk = lk + 3
          Next
       ElseIf j / 3 + 1 > n + 1 Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1): zuob(lk + 2) = bzuo(j + 2)
          lk = lk + 3
       End If
   Next

End If
If mysel(0).Closed = True Then
Set lne = ThisDrawing.ModelSpace.Add3DPoly(zuob)
lne.Closed = True
lne.Update
Else
Set lne = ThisDrawing.ModelSpace.Add3DPoly(zuob)
End If
mysel(0).Delete

ElseIf mysel(0).EntityType = 24 Then '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>二维线
bzuo = mysel(0).Coordinates
For i = 0 To UBound(bzuo) - 2 Step 2
    dis1 = Sqr((bzuo(i) - bzuo(i + 2)) ^ 2 + (bzuo(i + 1) - bzuo(i + 3)) ^ 2)
    dis2 = Sqr((bzuo(i) - add1(0)) ^ 2 + (bzuo(i + 1) - add1(1)) ^ 2) + Sqr((bzuo(i + 2) - add1(0)) ^ 2 + (bzuo(i + 3) - add1(1)) ^ 2)
    If dis2 - dis1 <= 0.01 Then
       m = (i + 2) / 2
    End If
    dis1 = Sqr((bzuo(i) - bzuo(i + 2)) ^ 2 + (bzuo(i + 1) - bzuo(i + 3)) ^ 2)
    dis2 = Sqr((bzuo(i) - add2(0)) ^ 2 + (bzuo(i + 1) - add2(1)) ^ 2) + Sqr((bzuo(i + 2) - add2(0)) ^ 2 + (bzuo(i + 3) - add2(1)) ^ 2)
    If dis2 - dis1 <= 0.01 Then
       n = (i + 2) / 2
    End If
Next

ReDim zuob(0 To (Val(strs) * (Abs(m - n) + 1)) * 2 + 2 * ((UBound(bzuo) + 1) / 2 - Abs(m - n) - 2) - 1) As Double
If m > n Then
   lk = 0
   For j = 0 To UBound(bzuo) Step 2
       If j / 2 + 1 < n Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
       ElseIf j / 2 + 1 >= n And j / 2 + 1 <= m Then
          For ll = 0 To strs - 1
          zuob(lk) = (ll + 1) * (bzuo((j + 2)) - bzuo(j)) / (strs + 1) + bzuo(j)
          zuob(lk + 1) = (ll + 1) * (bzuo(j + 3) - bzuo(j + 1)) / (strs + 1) + bzuo(j + 1)
          lk = lk + 2
          Next
       ElseIf j / 2 + 1 > m + 1 Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
       End If
   Next

ElseIf n > m Then
  lk = 0
   For j = 0 To UBound(bzuo) Step 2
       If j / 2 + 1 < m Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
       ElseIf j / 2 + 1 >= m And (j + 1) / 2 <= n Then
          For ll = 0 To strs - 1
          zuob(lk) = (ll + 1) * (bzuo((j + 2)) - bzuo(j)) / (strs + 1) + bzuo(j)
          zuob(lk + 1) = (ll + 1) * (bzuo(j + 3) - bzuo(j + 1)) / (strs + 1) + bzuo(j + 1)
          lk = lk + 2
          Next
       ElseIf j / 2 + 1 > n + 1 Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
       End If
   Next

End If
bbg = mysel(0).Elevation
If mysel(0).Closed = True Then
Set lne = ThisDrawing.ModelSpace.AddLightWeightPolyline(zuob)
lne.Closed = True
lne.Elevation = bbg
lne.Thickness = mysel(0).Thickness
lne.ConstantWidth = mysel(0).ConstantWidth
lne.Linetype = mysel(0).Linetype
lne.color = mysel(0).color
lne.Lineweight = mysel(0).Lineweight
lne.Update
Else
Set lne = ThisDrawing.ModelSpace.AddLightWeightPolyline(zuob)
lne.Elevation = bbg
lne.Thickness = mysel(0).Thickness
lne.ConstantWidth = mysel(0).ConstantWidth
lne.Linetype = mysel(0).Linetype
lne.color = mysel(0).color
lne.Lineweight = mysel(0).Lineweight
lne.Update
End If
mysel(0).Delete

End If
If mysel.count <> 0 Then
   mysel.Delete
End If
ThisDrawing.SetVariable "OSMODE", 0
End If
we:
End Sub

chtd

与大家交流分享，希望大家多提宝贵意见。

welcome0511

这么多原码,没人支持,我来顶一下

caizhiming

顶顶!!!

songzhao

不错很好谢谢楼主了

ry888

不错

xujinghai205

有种找到组织的感觉

lxgyes

ok