[分享]：用VBA实现ACAD的 Lengthen 命令的方法...

XDSoft

AutoCAD VBA example that implements a function similar to the Lengthen command  
ID    73114  
Applies to:    AutoCAD 2000
AutoCAD 2000I
AutoCAD 2002

Date    6/2/2002  




Question
Is there an example that uses GetEntity and GetPoint to implement a function
that will work like the Lengthen command on a line?
Answer
Here is an example procedure that is similar to the LENGTHEN command with the
DY parameter. There is not any error checking for clarity and would work on
LINE entities only.




Public Sub lengthenExample()
    Dim oLine As AcadLine
    Dim angle1 As Double
    Dim dist1 As Double, dist2 As Double, distStPntPickPnt As Double, halfLenOfLine As Double
    Dim pickedPnt2 As Variant, returnPnt As Variant
    Dim basePnt(0 To 2) As Double
    Dim lineObj As AcadLine
    Dim intPoints As Variant
    Dim myRay As AcadRay
   
    ThisDrawing.Utility.GetEntity oLine, pickedPnt2, "select object to lengthen"
     
    ' distance between the startpoint and
    ' the picked point
    dist1 = Abs((oLine.StartPoint(0) - pickedPnt2(0)) * (oLine.StartPoint(0) - pickedPnt2(0)))
    dist2 = Abs((oLine.StartPoint(1) - pickedPnt2(1)) * (oLine.StartPoint(1) - pickedPnt2(1)))
    distStPntPickPnt = Sqr(dist1 + dist2)
   
   ' Debug.Print "Distance between stPnt and pickedPnt " & dist3 ' for testing
   
    ' Use to determine which point should be modified
    halfLenOfLine = oLine.Length / 2
   
    ' this is 90 degrees
    angle1 = oLine.Angle - 1.57
   
    ' basePnt needs to be either the StartPoint or EndPoint
    ' of the selected line
     If distStPntPickPnt < halfLenOfLine Then
        basePnt(0) = oLine.StartPoint(0)
        basePnt(1) = oLine.StartPoint(1)
        basePnt(2) = oLine.StartPoint(2)


     Else
        basePnt(0) = oLine.EndPoint(0)
        basePnt(1) = oLine.EndPoint(1)
        basePnt(2) = oLine.EndPoint(2)
     End If
   
    returnPnt = ThisDrawing.Utility.GetPoint(basePnt, "Enter a point: ")
   
    Dim polarPnt As Variant
    Dim distance As Double
   
    ' the distance value is not important
    ' this line is going to be erased, it is just
    ' need for the IntersectWith function below
    distance = 5
    polarPnt = ThisDrawing.Utility.PolarPoint(returnPnt, angle1, distance)


    ' Create a ray from the base point to the polar point
     Set myRay = ThisDrawing.ModelSpace.AddRay(returnPnt, polarPnt)
   
    ' Find the intersection points
    ' intPoints = oLine.IntersectWith(lineObj, acExtendBoth)
     intPoints = oLine.IntersectWith(myRay, acExtendBoth)


    ' Change the StartPoint or EndPoint of the line
    If distStPntPickPnt < halfLenOfLine Then
        basePnt(0) = intPoints(0)
        basePnt(1) = intPoints(1)
        basePnt(2) = intPoints(2)
        oLine.StartPoint = basePnt
     Else
        basePnt(0) = intPoints(0)
        basePnt(1) = intPoints(1)
        basePnt(2) = intPoints(2)
        oLine.EndPoint = basePnt
     End If
        
     myRay.Delete
     
     ThisDrawing.Regen acActiveViewport


End Sub