作了几个程序

liusong0517

非常不错哦

kh0773

哪位大哥能告诉偶怎么用呀?

   是以什么格式保存啊?

chtd

几个线等分的例子：

Dim mysel As AcadSelectionSet
Dim lay As AcadLayer
Dim zb3(0 To 2) As Double
Dim zb2(0 To 2) As Double
Dim zbb(0 To 5) As Double
Dim zb As Variant
Dim jl As Double
Dim jl1 As Double
Dim jl2 As Double
Dim jl4 As Double
Dim zb1(0 To 2) As Double
Dim jd As Double
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
Dim sz As Long
Dim cd As Double
On Error GoTo dd
jl1 = ThisDrawing.Utility.GetString(0, "请输入离散点间距:")
dd = ThisDrawing.Utility.GetString(0, "请输入等分线长度:")
For Each selentity In mysel
   If selentity.EntityType = 2 Then
  
      zb = selentity.Coordinates
      jl = 0: sz = 2
      ReDim zuob(0 To sz) As Double
      For i = 0 To UBound(zb) - 3 Step 3
          'ReDim Preserve zuob(0 To sz) As Double
          jl2 = Sqr((zb(i) - zb(i + 3)) ^ 2 + (zb(i + 1) - zb(i + 4)) ^ 2)
          jl = jl + jl2
          If jl > jl1 Then
             jl4 = jl2 - (jl - jl1)
             Do Until jl < jl1
                ReDim Preserve zuob(0 To sz) As Double
                zuob(sz - 2) = jl4 * (zb(i + 3) - zb(i)) / jl2 + zb(i)
                zuob(sz - 1) = jl4 * (zb(i + 4) - zb(i + 1)) / jl2 + zb(i + 1)
                zuob(sz) = jl4 * (zb(i + 5) - zb(i + 2)) / jl2 + zb(i + 2)
                zb2(0) = zb(i): zb2(1) = zb(i + 1): zb2(2) = zb(i + 2)
                zb3(0) = zb(i + 3): zb3(1) = zb(i + 4): zb3(2) = zb(i + 5)
                zb1(0) = zuob(sz - 2): zb1(1) = zuob(sz - 1): zb1(2) = zuob(sz)
                jd = ThisDrawing.Utility.AngleFromXAxis(zb2, zb3)
                jd = 3.1415926 / 2 - jd
                'if jd
                cd = Val(dd) / 2
                zbb(0) = zb1(0) + cd * Cos(jd): zbb(1) = zb1(1) - cd * Sin(jd): zbb(2) = zb1(2)
                zbb(3) = zb1(0) - cd * Cos(jd): zbb(4) = zb1(1) + cd * Sin(jd): zbb(5) = zb1(2)
                ThisDrawing.ModelSpace.Add3DPoly zbb

                sz = sz + 3
                jl = jl - jl1
                jl4 = jl4 + jl1
             Loop
          End If
         
      Next
  
   End If
Next
mysel.Delete
dd:

chtd

Dim mysel As AcadSelectionSet
Dim lay As AcadLayer
Dim zb(0 To 2) As Double

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
On Error GoTo dd
cv = ThisDrawing.Utility.GetString(0, "请输入离散点间距:")
If Val(cv) > 0 Then
Set lay = ThisDrawing.Layers.Add("离散点")
ThisDrawing.ActiveLayer = lay
For Each selentity In mysel
If selentity.EntityType = 2 Then
   zuob = selentity.Coordinates
   zb(0) = zuob(3): zb(1) = zuob(4): zb(2) = zuob(5)
   ThisDrawing.Application.ZoomCenter zb, 1
   ThisDrawing.SendCommand "_measure" & vbCr & zb(0) & "," & zb(1) & "," & zb(2) & vbCr & cv & vbCr
selentity.Delete
End If
Next
ThisDrawing.Application.ZoomExtents
End If
mysel.Delete
dd:

Dim mysel As AcadSelectionSet
Dim lay As AcadLayer
Dim zb(0 To 2) As Double

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
On Error GoTo dd
cv = ThisDrawing.Utility.GetString(0, "请输入离散点间距:")
If Val(cv) > 0 Then
Set lay = ThisDrawing.Layers.Add("离散点")
ThisDrawing.ActiveLayer = lay
For Each selentity In mysel
If selentity.EntityType = 2 Then
   zuob = selentity.Coordinates
   zb(0) = zuob(3): zb(1) = zuob(4): zb(2) = zuob(5)
   ThisDrawing.Application.ZoomCenter zb, 1
   ThisDrawing.SendCommand "_divide" & vbCr & zb(0) & "," & zb(1) & "," & zb(2) & vbCr & cv & vbCr
selentity.Delete
End If
Next
ThisDrawing.Application.ZoomExtents
End If
mysel.Delete
dd:

AMTONNY

找到大哥的感觉，----以后有人帮忙了

董堃

顶，虽然我不懂是什么代码

yjc

非常好，谢谢你了

chtd

批处理改高程值

Dim fpoint As Variant
Dim tpoint(0 To 2) As Double
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

dd = ThisDrawing.Utility.GetString(0, "请输入要加的数值:")
dd1 = ThisDrawing.Utility.GetString(0, "请输入要保留小数位数:")
Dim dws As String
dws = "#######."
For i = 1 To dd1
    dws = dws + "0"
Next
For Each sel In mysel
    If sel.EntityType = 32 Or sel.EntityType = 21 Then
       sel.TextString = Format(Val(sel.TextString) + Val(dd), dws)
    ElseIf sel.EntityType = 7 Then
       fpoint = sel.InsertionPoint
       tpoint(0) = fpoint(0): tpoint(1) = fpoint(1)
       tpoint(2) = Val(Format(fpoint(2) + Val(dd), dws))
       sel.Move fpoint, tpoint
    ElseIf sel.EntityType = 22 Then
       fpoint = sel.Coordinates
       tpoint(0) = fpoint(0): tpoint(1) = fpoint(1)
       tpoint(2) = Val(Format(fpoint(2) + Val(dd), dws))
       sel.Move fpoint, tpoint
    End If
Next

If mysel.count <> 0 Then
   mysel.Delete
End If

chtd

三维线注标高

Dim zuobiao As Variant
Dim zuob As Variant
Dim zuobb(0 To 2) As Double
On Error GoTo we
For i = 0 To 10000
ThisDrawing.SetVariable "OSMODE", 512
aat = ThisDrawing.Utility.GetInput()
Dim mysel As AcadSelectionSet
If ThisDrawing.SelectionSets.count = 0 Then
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
zuobiao = ThisDrawing.Utility.GetPoint(, "请选择:")
mysel.SelectAtPoint zuobiao
Else
ThisDrawing.SelectionSets.Item(0).Delete
AppActivate ThisDrawing.Application.Caption
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
zuobiao = ThisDrawing.Utility.GetPoint(, "请选择:")
mysel.SelectAtPoint zuobiao
End If
ThisDrawing.SetVariable "OSMODE", 0
If mysel.count = 1 Then
  If mysel(0).EntityType = 2 Then
  zuob = mysel(0).Coordinates
  zuobb(0) = zuobiao(0): zuobb(1) = zuobiao(1): zuobb(2) = zuob(2)
   retAngle = ThisDrawing.Utility.GetAngle(, "Enter an angle: ")
   Set zj2 = ThisDrawing.ModelSpace.addtext(Int(zuob(2)), zuobb, 3.75)
   zj2.Alignment = acAlignmentMiddle
   zj2.TextAlignmentPoint = zuobb
   zj2.ScaleFactor = 1
   zj2.Rotation = retAngle - 80
   zj2.Update
End If
  End If
If mysel.count <> 0 Then
   mysel.Delete
End If
Next
we:
ThisDrawing.SetVariable "OSMODE", 0

chtd

拿出一些程序原码与大家交流，希望与大家探讨，共同进步！