明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 22196|回复: 57

作了几个程序

  [复制链接]
发表于 2007-12-10 21:42 | 显示全部楼层 |阅读模式

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

 

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2017-12-8 16:34 | 显示全部楼层
你好,那个加载了lsp后提示no function definition: CENTSEL是怎么回事,有解决方法不
 楼主| 发表于 2007-12-10 21:45 | 显示全部楼层

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

 楼主| 发表于 2007-12-10 21:47 | 显示全部楼层

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

点评

谢谢分享  发表于 2012-3-15 19:29
 楼主| 发表于 2007-12-10 21:50 | 显示全部楼层
与大家交流分享,希望大家多提宝贵意见。
发表于 2008-1-17 18:36 | 显示全部楼层
这么多原码,没人支持,我来顶一下
发表于 2008-1-30 12:02 | 显示全部楼层
顶顶!!!
发表于 2008-1-31 15:55 | 显示全部楼层

不错很好谢谢楼主了

发表于 2008-2-21 20:26 | 显示全部楼层

不错

发表于 2008-3-14 15:36 | 显示全部楼层

有种找到组织的感觉

发表于 2008-3-16 07:52 | 显示全部楼层
ok
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 14:52 , Processed in 0.261036 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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