Some help?
Thanks in advance.
Public Sub BLF()
Dim sspo As AcadSelectionSet, gpcode(0) As Integer, datavalue(0) As Variant
Dim ent As AcadEntity, checkset As Integer
Dim txs As String, pp As Variant, pp1 As Variant, ht As Double
On Error Resume Next
With ThisDrawing
For checkset = 1 To .SelectionSets.Count
If .SelectionSets.Item(checkset - 1).Name = "temp" Then .SelectionSets("temp").Delete
Next checkset
On Error GoTo 0
Set sspo = .SelectionSets.Add("temp")
End With
gpcode(0) = 8: datavalue(0) = "PNO"
sspo.Select acSelectionSetAll, , , gpcode, datavalue
For Each ent In ThisDrawing.SelectionSets("temp")
txs = ent.TextString: pp = ent.InsertionPoint: ht = ent.Height: pp1 = ThisDrawing.Utility.PolarPoint(pp, 3 * Atn(1), ht * Sqr(2))
Trim (ent.TextString)
Select Case Trim(txs)
Case "MU"
Call tomb(pp, pp1, ht)
Case "E"
Call Eleck(pp, pp1, ht)
Case Else
ent.Update
End Select
Next
End Sub
Sub tomb(pp, pp1, ht)
Dim ap As Double
Dim sp As Variant, ep As Variant, ltomb As AcadLayer
Dim objBlkRef As AcadBlockReference
Dim objBlock As AcadBlock
ap = ThisDrawing.GetVariable("viewtwist")
On Error Resume Next
Set objBlock = ThisDrawing.Blocks("Tomb")
Set ltomb = ThisDrawing.Layers.Add("Tomb")
ltomb.color = 1
ThisDrawing.ActiveLayer = ltomb
Dim c1 As Double, c2 As Double
c1 = 2 * Atn(1): c2 = 4 * Atn(1)
If objBlock.Count Then
objBlock.Delete
End If
On Error GoTo ErrorHandler
Dim dblPnt(2) As Double
dblPnt(0) = 0#: dblPnt(1) = 0#: dblPnt(2) = 0#
Set objBlock = ThisDrawing.Blocks.Add(dblPnt, "Tomb")
Dim cp As Variant, sp1 As Variant, ep1 As Variant
Dim edp As Variant, ac As AcadArc, r As Double
Dim stp(2) As Double, s As Double
pp1 = ThisDrawing.Utility.PolarPoint(pp, 3 * Atn(1) - ap, ht * Sqr(2))
stp(0) = 0: stp(1) = 0: stp(2) = 0
sp = ThisDrawing.Utility.PolarPoint(stp, c2 - ap, 0.81)
edp = ThisDrawing.Utility.PolarPoint(stp, -ap, 0.81)
objBlock.AddLine sp, edp
ep = ThisDrawing.Utility.PolarPoint(stp, c1 - ap, 0.54)
objBlock.AddLine stp, ep
sp1 = ThisDrawing.Utility.PolarPoint(stp, -ap, 0.54)
ep1 = ThisDrawing.Utility.PolarPoint(sp1, c1 - ap, 1.08)
objBlock.AddLine sp1, ep1
sp = ThisDrawing.Utility.PolarPoint(stp, c2 - ap, 0.54)
ep = ThisDrawing.Utility.PolarPoint(sp, c1 - ap, 1.08)
objBlock.AddLine sp, ep
cp = ThisDrawing.Utility.PolarPoint(ep1, c2 - ap, 0.54)
r = 0.54
objBlock.AddArc cp, r, -ap, c2 - ap
s = ht * 5
Set objBlkRef = ThisDrawing.ModelSpace.InsertBlock(pp1, "Tomb", s / 4, s / 4, s / 4, 0)
Exit Sub
ErrorHandler:
If Err Then
MsgBox Err.Description
Err.Clear
End If
Set objBlkRef = Nothing
End Sub
Sub Eleck(pp, pp1, ht)
Dim ap As Double
Dim sp As Variant, ep As Variant, leleck As AcadLayer
Dim objBlkRef As AcadBlockReference
Dim objBlock As AcadBlock
ap = ThisDrawing.GetVariable("viewtwist")
On Error Resume Next
Set objBlock = ThisDrawing.Blocks("Eleck")
Set leleck = ThisDrawing.Layers.Add("Eleck")
leleck.color = 44
ThisDrawing.ActiveLayer = leleck
Dim c1 As Double, c2 As Double
c1 = 2 * Atn(1): c2 = 4 * Atn(1)
If objBlock.Count Then
objBlock.Delete
End If
On Error GoTo ErrorHandler
Dim dblPnt(2) As Double, cp(2) As Double, pp2 As Variant
dblPnt(0) = 0#: dblPnt(1) = 0#: dblPnt(2) = 0#
Set objBlock = ThisDrawing.Blocks.Add(dblPnt, "Eleck")
pp1 = ThisDrawing.Utility.PolarPoint(pp, 3 * Atn(1) - ap, ht * Sqr(2))
Dim cir As AcadCircle, r As Double, s As Double
cp(0) = 0: cp(1) = 0: cp(2) = 0: r = ht * 1.2: s = ht * 2
objBlock.AddCircle cp, r
pp2 = ThisDrawing.Utility.PolarPoint(cp, 5 * Atn(1) + Atn(1) / 4, ht / 2)
objBlock.AddText "E", pp2, ht
Set objBlkRef = ThisDrawing.ModelSpace.InsertBlock(pp1, "Eleck", s, s, s, -ap)
ErrorHandler:
If Err Then
MsgBox Err.Description
Err.Clear
End If
Set objBlkRef = Nothing
End Sub