.NET

Reply
Distinguished Contributor
gilseorin
Posts: 177
Registered: ‎09-05-2006
Message 1 of 1 (87 Views)

Equivalent .net for vba?

87 Views, 0 Replies
10-16-2006 11:09 PM
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
Announcements
Are you familiar with the Autodesk Expert Elites? The Expert Elite program is made up of customers that help other customers by sharing knowledge and exemplifying an engaging style of collaboration. To learn more, please visit our Expert Elite website.
Need installation help?

Start with some of our most frequented solutions or visit the Installation and Licensing Forum to get help installing your software.