Category: AutoCAD

Това е VBA скрипт за завъртане на блокове, перпендикулярно на дадена базова линия. Програмата изчертава и линия по перпендикуляра до базовата линия.

Private Sub CommandButton1_Click() 
    HALF_PI = 2 * Atn(1)
    PI = 4 * Atn(1)
    Me.hide
    On Error GoTo ShowForm
    Dim selectedBlockEntity As AcadEntity
    Dim blockSelectionSet As AcadSelectionSet
    Set blockSelectionSet = AddSelectionSet("Blocks")
    blockSelectionSet.Clear
    blockSelectionSet.SelectOnScreen
    For Each selectedBlockEntity In blockSelectionSet
        On Error Resume Next
        If TypeOf selectedBlockEntity Is AcadBlockReference Then
            Dim blockReference As AcadBlockReference
            Set blockReference = selectedBlockEntity
            blockReference.Highlight True
            Dim baseLineStartPoint() As Double
            Dim baseLineEndPoint() As Double
            baseLineStartPoint = ThisDrawing.Utility.GetPoint(, "Select base line start point: ")
            baseLineEndPoint = ThisDrawing.Utility.GetPoint(, "Select base line end point: ")
            Dim baseLine As AcadLine
            Set baseLine = ThisDrawing.ModelSpace.AddLine(baseLineStartPoint, baseLineEndPoint)
            Dim headingAngle As Double
            headingAngle = Atan2(baseLineEndPoint(0) - baseLineStartPoint(0), baseLineEndPoint(1) - baseLineStartPoint(1))
            blockReference.Rotation = headingAngle + PI
            Dim blockReferenceInsertionPoint() As Double
            blockReferenceInsertionPoint = blockReference.InsertionPoint
            Set blockReference = Nothing
            Dim baseLineAngle As Double
            baseLineAngle = baseLine.Angle - HALF_PI
            Dim polarPoint() As Double
            polarPoint = ThisDrawing.Utility.polarPoint(blockReferenceInsertionPoint, baseLineAngle, 10)
            Dim extendedLine As AcadLine
            Set extendedLine = ThisDrawing.ModelSpace.AddLine(blockReferenceInsertionPoint, polarPoint)
            Dim intersectionPoint() As Double
            intersectionPoint = baseLine.IntersectWith(extendedLine, acExtendBoth)
            extendedLine.EndPoint = intersectionPoint
            extendedLine.Linetype = "L175"
            extendedLine.Update
            baseLine.Delete
        End If
    Next selectedBlockEntity
ShowForm:
    Me.show
End Sub
Private Function AddSelectionSet(setName As String) As AcadSelectionSet
    On Error Resume Next
    Set AddSelectionSet = ThisDrawing.SelectionSets.Add(setName)
    If Err.Number <> 0 Then
        Set AddSelectionSet = ThisDrawing.SelectionSets.Item(setName)
    End If
End Function
Private Function Atan2(X As Variant, Y As Variant) As Variant
    PI = 3.14159265358979
    PI_2 = 1.5707963267949
    Select Case X
         Case Is > 0
             Atan2 = Atn(Y / X)
         Case Is < 0             
            Atan2 = Atn(Y / X) + PI * Sgn(Y)             
            If Y = 0 Then 
                ArcTan2 = ArcTan2 + PI         
         Case Is = 0             
            Atan2 = PI_2 * Sgn(Y)     
    End Select 
End Function