Това е 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 
