how to create this block

how to create this block

Anonymous
Not applicable
547 Views
0 Replies
Message 1 of 1

how to create this block

Anonymous
Not applicable

I want  create a blocka circle and a line in this block,then i insert this block into my document,

 

i need the normal of circle is pointing current  Z axis of ucs,the endpoint of line is pointing current X axis of ucs(any ucs), but my codes work is not my  effect, any one who see this message can help me?

 

Sub insblk()
With ThisDrawing
Dim ucs As AcadUCS
Dim org As Variant, xvec As Variant, yvec As Variant
org = .GetVariable("ucsorg")
xvec = .GetVariable("ucsxdir")
yvec = .GetVariable("ucsydir")
xvec(0) = xvec(0) + org(0)
xvec(1) = xvec(1) + org(1)
xvec(2) = xvec(2) + org(2)
yvec(0) = yvec(0) + org(0)
yvec(1) = yvec(1) + org(1)
yvec(2) = yvec(2) + org(2)

Set ucs = .UserCoordinateSystems.Add(org, xvec, yvec, "123")

.ActiveUCS = ucs
Dim blks As AcadBlocks
Dim blk As AcadBlock
Set blks = .Blocks
Dim baspt As Variant
Dim nor As Variant
Normal = NewPnt3d(0, 0, 1)
baspt = .Utility.TranslateCoordinates(NewPnt3d(0, 0, 0), acUCS, acWorld, False)

Set blk = blks.Add(NewPnt3d(0, 0, 0), "1")
Dim cir As AcadCircle
Set cir = blk.AddCircle(NewPnt3d(0, 0, 0), 10)
Normal = .Utility.TranslateCoordinates(NewPnt3d(0, 0, 1), acUCS, acWorld, False)
'cir.Normal = Normal
'cir.Update
Dim lne As AcadLine

Dim p2 As Variant
p2 = .Utility.TranslateCoordinates(NewPnt3d(10, 0, 0), acUCS, acOCS, False, Normal)

Set lne = blk.AddLine(NewPnt3d(0, 0, 0), NewPnt3d(10, 0, 0))

Dim blkref As AcadBlockReference

Set blkref = .ModelSpace.InsertBlock(NewPnt3d(0, 0, 0), blk.Name, 1, 1, 1, 0)

 

blkref.TransformBy ucs.GetUCSMatrix


blkref.Update
Dim xpt As Variant
xpt = .GetVariable("ucsxdir")

xpt = .Utility.TranslateCoordinates(xpt, acWorld, acOCS, False, Normal)

 

'Dim ang As Double
'ang = .Utility.AngleFromXAxis(baspt, xpt)
'MsgBox ang
'blkref.Rotate baspt, ang

End With

End Sub


Public Function Aspnt3d(pt As pnt3d) As Variant
Dim retu(2) As Double
retu(0) = pt.x: retu(1) = pt.y: retu(2) = pt.z
aspnt3 = retu
End Function

Public Function NewPnt3d(x As Double, y As Double, z As Double) As Variant
Dim retu(2) As Double
retu(0) = x: retu(1) = y: retu(2) = z
NewPnt3d = retu
End Function

 

0 Likes
548 Views
0 Replies
Replies (0)