.NET
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Equivalent .net for vba?

0 REPLIES 0
Reply
Message 1 of 1
gilseorin
237 Views, 0 Replies

Equivalent .net for vba?

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
0 REPLIES 0

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk DevCon in Munich May 28-29th


Autodesk Design & Make Report

”Boost