一个修测曲线(Vba开发)的例子

chtd

Sub xcqx()
On Error GoTo xu
Dim mysel As AcadSelectionSet
Dim xzd As Variant
Dim addp As Variant
Dim xzd1(0 To 2) As Double
Dim bzuo As Variant
Dim lin As AcadLWPolyline
Dim lim As Acad3DPolyline
If ThisDrawing.SelectionSets.Count = 0 Then
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
ThisDrawing.SetVariable "OSMODE", 512
'ThisDrawing.ObjectSnapMode = True
xzd = ThisDrawing.Utility.GetPoint(, "修测起点:")
mysel.SelectAtPoint xzd
Else
ThisDrawing.SelectionSets.Item(0).Delete
Set mysel = ThisDrawing.SelectionSets.Add("mysel")
AppActivate ThisDrawing.Application.Caption
ThisDrawing.SetVariable "OSMODE", 512
'ThisDrawing.ObjectSnapMode = True
xzd = ThisDrawing.Utility.GetPoint(, "修测起点:")
mysel.SelectAtPoint xzd
End If

xzd1(0) = xzd(0): xzd1(1) = xzd(1): xzd1(2) = xzd(2)
If mysel.Count = 1 Then
mysel(0).Highlight True
ThisDrawing.ActiveLayer = ThisDrawing.Layers(mysel(0).Layer)
If mysel(0).EntityType = 24 Then '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>二维线
ReDim zuob1(0 To 1) As Double
zuob1(0) = xzd(0): zuob1(1) = xzd(1)
On Error GoTo we
ThisDrawing.SetVariable "OSMODE", 0
For i = 1 To 1000
addp = ThisDrawing.Utility.GetPoint(xzd, "请输入")
xzd(0) = addp(0): xzd(1) = addp(1): xzd(2) = addp(2)
If Not lin Is Nothing Then
lin.Delete
End If

ReDim Preserve zuob1(0 To 2 * (i + 1) - 1) As Double
zuob1(2 * (i + 1) - 2) = addp(0): zuob1(2 * (i + 1) - 1) = addp(1)
Set lin = ThisDrawing.ModelSpace.AddLightWeightPolyline(zuob1)
lin.Highlight True
Next
we:
If Not lin Is Nothing 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) - xzd1(0)) ^ 2 + (bzuo(i + 1) - xzd1(1)) ^ 2) + Sqr((bzuo(i + 2) - xzd1(0)) ^ 2 + (bzuo(i + 3) - xzd1(1)) ^ 2)
    If dis2 - dis1 <= 0.1 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) - xzd(0)) ^ 2 + (bzuo(i + 1) - xzd(1)) ^ 2) + Sqr((bzuo(i + 2) - xzd(0)) ^ 2 + (bzuo(i + 3) - xzd(1)) ^ 2)
    If dis2 - dis1 <= 0.1 Then
       n = (i + 2) / 2
    End If
Next

ReDim zuob(0 To UBound(zuob1) + 2 * (-Abs(m - n)) + UBound(bzuo) + 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 + 1 Then
          For k = UBound(zuob1) To 0 Step -2
          zuob(lk) = zuob1(k - 1): zuob(lk + 1) = zuob1(k)
          lk = lk + 2
          Next
       ElseIf j / 2 + 1 > m 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 + 1 Then
          For k = 0 To UBound(zuob1) Step 2
          zuob(lk) = zuob1(k): zuob(lk + 1) = zuob1(k + 1)
          lk = lk + 2
          Next
       ElseIf j / 2 + 1 > n Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
       End If
   Next

ElseIf n = m Then
ReDim zuob(0 To UBound(zuob1) + UBound(bzuo) + 1) As Double
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 Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
          dis01 = Sqr((bzuo(j) - zuob1(0)) ^ 2 + (bzuo(j + 1) - zuob1(1)) ^ 2)
          dis02 = Sqr((bzuo(j) - zuob1(UBound(zuob1) - 1)) ^ 2 + (bzuo(j + 1) - zuob1(UBound(zuob1))) ^ 2)
          If dis01 < dis02 Then
          For k = 0 To UBound(zuob1) Step 2
          zuob(lk) = zuob1(k): zuob(lk + 1) = zuob1(k + 1)
          lk = lk + 2
          Next
          Else
          For k = UBound(zuob1) To 0 Step -2
          zuob(lk) = zuob1(k - 1): zuob(lk + 1) = zuob1(k)
          lk = lk + 2
          Next
          End If
       ElseIf j / 2 + 1 > m Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1)
          lk = lk + 2
       End If
Next
End If
If mysel(0).Closed = True Then
Set lin1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(zuob)
lin1.Elevation = mysel(0).Elevation
lin1.Closed = True
lin1.Update
Else
Set lin1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(zuob)
lin1.Elevation = mysel(0).Elevation
lin1.Update
End If
mysel(0).Delete
lin.Delete
End If

ElseIf mysel(0).EntityType = 2 Then '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>三维线
ReDim zuob1(0 To 2) As Double
zuob1(0) = xzd(0): zuob1(1) = xzd(1): zuob1(2) = xzd(2)
On Error GoTo we1
ThisDrawing.SetVariable "OSMODE", 0
For i = 1 To 1000
addp = ThisDrawing.Utility.GetPoint(xzd, "请输入")
xzd(0) = addp(0): xzd(1) = addp(1): xzd(2) = xzd1(2)

If Not lim Is Nothing Then
lim.Delete
End If

ReDim Preserve zuob1(0 To 3 * (i + 1) - 1) As Double
zuob1(3 * (i + 1) - 3) = addp(0): zuob1(3 * (i + 1) - 2) = addp(1): zuob1(3 * (i + 1) - 1) = xzd1(2)
Set lim = ThisDrawing.ModelSpace.Add3DPoly(zuob1)
lim.Highlight True
Next
we1:
If Not lim Is Nothing 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) - xzd1(0)) ^ 2 + (bzuo(i + 1) - xzd1(1)) ^ 2) + Sqr((bzuo(i + 3) - xzd1(0)) ^ 2 + (bzuo(i + 4) - xzd1(1)) ^ 2)
    If dis2 - dis1 <= 0.1 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) - xzd(0)) ^ 2 + (bzuo(i + 1) - xzd(1)) ^ 2) + Sqr((bzuo(i + 3) - xzd(0)) ^ 2 + (bzuo(i + 4) - xzd(1)) ^ 2)
    If dis2 - dis1 <= 0.1 Then
       n = (i + 3) / 3
    End If
Next

ReDim zuob(0 To UBound(zuob1) + 3 * (-Abs(m - n)) + UBound(bzuo) + 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 + 1 Then
          For k = UBound(zuob1) To 0 Step -3
          zuob(lk) = zuob1(k - 2): zuob(lk + 1) = zuob1(k - 1): zuob(lk + 2) = zuob1(k)
          lk = lk + 3
          Next
       ElseIf j / 3 + 1 > m 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 + 1 Then
          For k = 0 To UBound(zuob1) Step 3
          zuob(lk) = zuob1(k): zuob(lk + 1) = zuob1(k + 1): zuob(lk + 2) = zuob1(k + 2)
          lk = lk + 3
          Next
       ElseIf j / 3 + 1 > n 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
ReDim zuob(0 To UBound(zuob1) + UBound(bzuo) + 1) As Double
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 Then
          zuob(lk) = bzuo(j): zuob(lk + 1) = bzuo(j + 1): zuob(lk + 2) = bzuo(j + 2)
          lk = lk + 3
          dis01 = Sqr((bzuo(j) - zuob1(0)) ^ 2 + (bzuo(j + 1) - zuob1(1)) ^ 2)
          dis02 = Sqr((bzuo(j) - zuob1(UBound(zuob1) - 2)) ^ 2 + (bzuo(j + 1) - zuob1(UBound(zuob1) - 1)) ^ 2)
          If dis01 < dis02 Then
          For k = 0 To UBound(zuob1) Step 3
          zuob(lk) = zuob1(k): zuob(lk + 1) = zuob1(k + 1): zuob(lk + 2) = zuob1(k + 2)
          lk = lk + 3
          Next
          Else
          For k = UBound(zuob1) To 0 Step -3
          zuob(lk) = zuob1(k - 2): zuob(lk + 1) = zuob1(k - 1): zuob(lk + 2) = zuob1(k)
          lk = lk + 3
          Next
          End If
       ElseIf j / 3 + 1 > m 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 lim1 = ThisDrawing.ModelSpace.Add3DPoly(zuob)
lim1.Closed = True
lim1.Update
Else
Set lim1 = ThisDrawing.ModelSpace.Add3DPoly(zuob)
lim1.Update
End If
mysel(0).Delete
lim.Delete
End If
End If
If mysel.Count <> 0 Then
mysel.Delete
End If
End If
xu:
End Sub

    与大家交流，提高自己的水平！！！！

游戏人间

如果目标的是两条线，如何修测？