.NET

Reply
Valued Contributor
Ron_M
Posts: 68
Registered: ‎12-09-2013
Message 1 of 3 (151 Views)
Accepted Solution

Insert To Point

151 Views, 2 Replies
04-30-2014 10:26 AM

ACA 2014, WIndows 7 64, VS 2013 Express, VB.Net

 

Working on conversion of our block library to VB.Net from VBA.  I'm having the following issue - I am able to insert multiple blocks from the library however all blocks are placed in the drawing with the block base point at 0, 0, 0 regardless of the point picked in the drawing.  Below is the code for both my library and jig.  Any and all assistance is welcome.  Making fun of my code is also welcome as right now I need a laugh.

 

Library.vb

Imports System
Imports System.IO
Imports System.Windows.Controls
Imports Autodesk.AutoCAD
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Runtime

Public Class Library
    Dim acDoc As Document = Application.DocumentManager.MdiActiveDocument
    Dim itemstr As String
    Dim ed As Editor

    Private Sub Library_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        For Each i As String In Directory.GetDirectories("R:\2014\Library\")
            ListView1.Items.Add(Path.GetFileName(i))
        Next
        ListView1.Items.Remove(ListView1.Items(0))
        If ListView1.Items.Count > 0 Then
            ListView1.Items(0).Focused = True
            ListView1.Items(0).Selected = True
            itemstr = (Me.ListView1.FocusedItem.Text)
            PictureBox1.ImageLocation = ("R:\2014\Library\" & itemstr & "\template.wmf")
        End If
    End Sub

    Private Sub ListView1_SelectedIndexChanged(sender As Object, e As EventArgs) Handles ListView1.SelectedIndexChanged
        If Me.ListView1.SelectedItems.Count > 0 Then
            itemstr = (Me.ListView1.FocusedItem.Text)
            PictureBox1.ImageLocation = ("R:\2014\Library\" & itemstr & "\template.wmf")
        End If
    End Sub

    Private Sub PictureBox1_MouseClick(sender As Object, e As System.Windows.Forms.MouseEventArgs) Handles PictureBox1.MouseClick
        Dim xPos As Integer
        Dim yPos As Integer
        If e.Button = System.Windows.Forms.MouseButtons.Left Then
            xPos = e.X
            yPos = e.Y
        End If
        doit(xPos, yPos, itemstr)
    End Sub

    Private Sub doit(ByVal xPos As Single, ByVal yPos As Single, itemstr As String)
        Dim box As String
        Dim x As Integer
        Dim y As Integer
        x = (Int(xPos / 100))
        y = (Int(yPos / 100))
        If y > 0 Then
            box = (Int((x) + (Int(y) * 8)))
        Else : box = x
        End If

        'Layers
        Using Myreader As New Microsoft.VisualBasic.FileIO.TextFieldParser("R:\2014\Library\" & itemstr & "\layers.lst")
            Myreader.TextFieldType = FileIO.FieldType.Delimited
            Myreader.SetDelimiters(",")
            While Not Myreader.EndOfData
                Try
                    Dim fields() As String = Myreader.ReadFields
                    Dim layer As String = (fields(box))
                    addlayer(layer)
                Finally
                End Try
            End While
        End Using

        'Blocks
        Using Myreaderblocks As New Microsoft.VisualBasic.FileIO.TextFieldParser("R:\2014\Library\" & itemstr & "\library.lst")
            Myreaderblocks.TextFieldType = FileIO.FieldType.Delimited
            Myreaderblocks.SetDelimiters(",")
            While Not Myreaderblocks.EndOfData
                Try
                    Dim fields() As String = Myreaderblocks.ReadFields
                    Dim currentField As String = (fields(box))
                    If currentField.Length > 5 Then
                        result = currentField.Substring(currentField.Length - 3)
                    End If
                    Dim BlockName As String = currentField.Substring(0, currentField.Length - 6)
                    If Not result = "" Then
                        Select Case result
                            Case "dwg"
                                addblock(BlockName, currentField, itemstr)
                        End Select
                    End If
                Catch ex As Microsoft.VisualBasic.FileIO.MalformedLineException
                End Try
            End While
        End Using

    End Sub

    Public Sub addlayer(ByVal layer As String)
        'Dim myDWG As ApplicationServices.Document
        'Dim myDB As DatabaseServices.Database
        'Dim myTransMan As DatabaseServices.TransactionManager
        'Dim myTrans As DatabaseServices.Transaction

        'myDWG = ApplicationServices.Application.DocumentManager.MdiActiveDocument
        'myDB = myDWG.Database
        'myTransMan = myDWG.TransactionManager
        'myTrans = myTransMan.StartTransaction

        'Dim myLT As DatabaseServices.LayerTable
        'Dim myLayer As New DatabaseServices.LayerTableRecord
        'Dim myLayerId As ObjectId

        'Dim LayerName As String = layer

        '' Verify that layer exists or not
        'Try
        '    ' If Layer Exist recover LayerID
        '    myLT = CType(myTransMan.GetObject(myDB.LayerTableId, OpenMode.ForRead, True, True), LayerTable)
        '    myLayerId = myLT.Item(LayerName)
        '    ' If Deleted => Recover Layer
        '    If myLayerId.IsErased Then
        '        myLT.UpgradeOpen()
        '        myLT.Item(LayerName).GetObject(OpenMode.ForWrite, True, True).Erase(False)
        '    End If

        '    ' Layer Doesn't Exist: Create it
        '    myLT = myDB.LayerTableId.GetObject(DatabaseServices.OpenMode.ForWrite, True, True)
        '    myLayer.Name = LayerName
        '    myLT.Add(myLayer)
        '    ' Add Layer to DB
        '    myTrans.AddNewlyCreatedDBObject(myLayer, True)
        '    ' Recover LayerID of newly created Layer
        '    myLT = CType(myTransMan.GetObject(myDB.LayerTableId, OpenMode.ForRead, False), LayerTable)
        '    myLayerId = myLT.Item(LayerName)
        'Catch ex As Autodesk.AutoCAD.DatabaseServices.DataAdapterSourceFilesException
        'End Try

        '' Set Layer as Current
        'myDB.Clayer = myLayerId

        'myTrans.Commit()
        'myTrans.Dispose()
        'myTransMan.Dispose()
    End Sub ' Set as Current Layer 

    Public Sub addblock(ByVal blockname As String, ByVal currentfield As String, ByVal itemstr As String)
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Using OpenDb As New Database(False, True)
            OpenDb.ReadDwgFile("R:\2014\Library\" & itemstr & "\" & currentfield, System.IO.FileShare.ReadWrite, True, "")
            acDoc.LockDocument()
            Dim ids As New ObjectIdCollection()
            Using tr As Transaction = OpenDb.TransactionManager.StartTransaction()
                'For example, Get the block by name "BlkName"
                Dim bt As BlockTable
                bt = DirectCast(tr.GetObject(OpenDb.BlockTableId, OpenMode.ForRead), BlockTable)
                If bt.Has(blockname) Then
                    ids.Add(bt(blockname))
                End If
                tr.Commit()
            End Using
            'if not found, add the block
            If ids.Count <> 0 Then
                'get the current drawing database
                Dim destdb As Database = acDoc.Database
                Dim iMap As New IdMapping()
                acDoc.LockDocument()
                destdb.WblockCloneObjects(ids, destdb.BlockTableId, iMap, DuplicateRecordCloning.Ignore, False)
            End If
        End Using
        Dispose()
        InsertBlockWithJig(blockname, layer)
    End Sub

    Public Sub InsertBlockWithJig(ByVal blockname As String, layer As String)
        Dim myDB As Database
        myDB = HostApplicationServices.WorkingDatabase
        Dim myJig As BlockJig
        Using myTrans As Transaction = myDB.TransactionManager.StartTransaction
            Dim myBT As BlockTable = myDB.BlockTableId.GetObject(OpenMode.ForRead)
            If myBT.Has(blockname) Then
                Dim myBTR As BlockTableRecord = myBT(blockname).GetObject(OpenMode.ForRead)
                myJig = New BlockJig(New Geometry.Point3d(0, 0, 0), myBTR.ObjectId)
            Else
                Exit Sub
            End If
        End Using
        Dim myBlkID As ObjectId
        Dim SelPt As EditorInput.PromptPointResult
        Do
            SelPt = myJig.BeginJig
            If Not SelPt Is Nothing Then
                Select Case SelPt.Status
                    Case EditorInput.PromptStatus.OK
                        myBlkID = insertblock(BasePt, blockname)
                    Case EditorInput.PromptStatus.Other
                        Exit Sub
                End Select
            End If
            If SelPt Is Nothing Then Exit Do
        Loop While SelPt.Status = EditorInput.PromptStatus.OK
    End Sub

    Public Function insertblock(BasePt As Point3d, blockname As String)
        Dim db As Database = Application.DocumentManager.MdiActiveDocument.Database
        Using myT As Transaction = db.TransactionManager.StartTransaction()
            'Get the block definition "Check".
            Dim bt As BlockTable = TryCast(db.BlockTableId.GetObject(OpenMode.ForRead), BlockTable)
            Dim blockDef As BlockTableRecord = TryCast(bt(blockname).GetObject(OpenMode.ForRead), BlockTableRecord)
            'Also open modelspace - we'll be adding our BlockReference to it
            Dim ms As BlockTableRecord = TryCast(bt(BlockTableRecord.ModelSpace).GetObject(OpenMode.ForWrite), BlockTableRecord)

            'Create new BlockReference, and link it to our block definition
            Using blockRef As New BlockReference(BasePt, blockDef.ObjectId)
                'Add the block reference to modelspace
                ms.AppendEntity(blockRef)
                myT.AddNewlyCreatedDBObject(blockRef, True)

                'Iterate block definition to find all non-constant AttributeDefinitions
                For Each id As ObjectId In blockDef
                    Dim obj As DBObject = id.GetObject(OpenMode.ForRead)
                    Dim attDef As AttributeDefinition = TryCast(obj, AttributeDefinition)
                    If (attDef IsNot Nothing) AndAlso (Not attDef.Constant) Then
                        'This is a non-constant AttributeDefinition
                        'Create a new AttributeReference
                        Using attRef As New AttributeReference()
                            attRef.SetAttributeFromBlock(attDef, blockRef.BlockTransform)
                            'Add the AttributeReference to the BlockReference
                            blockRef.AttributeCollection.AppendAttribute(attRef)
                            myT.AddNewlyCreatedDBObject(attRef, True)
                        End Using
                    End If
                Next
            End Using
            acDoc.TransactionManager.QueueForGraphicsFlush()
            myT.Commit()
        End Using
    End Function

End Class

 BlockJig.vb

Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD

Public Class BlockJig
    Inherits Autodesk.AutoCAD.EditorInput.EntityJig
    Dim BasePt As Point3d = New Point3d(0, 0, 0)
    Dim myMatrix As Matrix3d
    Dim myBRef As DatabaseServices.BlockReference
    Dim myOpts As EditorInput.JigPromptPointOptions
    Dim CurrentKeyword As String

    Sub New(ByVal BlockIns As Point3d, ByVal BlockID As ObjectId)
        MyBase.New(New DatabaseServices.BlockReference(BlockIns, BlockID))
        myBRef = Me.Entity
    End Sub

    Function BeginJig() As PromptPointResult
        If myOpts Is Nothing Then
            myOpts = New EditorInput.JigPromptPointOptions()
            myOpts.Message = vbCrLf & "Select a point:"
            myOpts.Cursor = EditorInput.CursorType.Invisible
            myOpts.UseBasePoint = False
        End If
        Dim ed As EditorInput.Editor = Application.DocumentManager.MdiActiveDocument.Editor
        Dim myPR As PromptResult
        myPR = ed.Drag(Me)
        Do
            Select Case myPR.Status
                Case EditorInput.PromptStatus.OK
                    Return myPR
                    Exit Do
                Case EditorInput.PromptStatus.None
                    Return myPR
                    Exit Do
                Case EditorInput.PromptStatus.Other
                    Return myPR
                    Exit Do
            End Select
        Loop While myPR.Status <> EditorInput.PromptStatus.Cancel
        Return Nothing
    End Function
    Protected Overrides Function Sampler(ByVal prompts As JigPrompts) As SamplerStatus
        Dim myPPR As PromptPointResult
        myPPR = prompts.AcquirePoint(myOpts)
        'Dim curPos As Point3d
        'curPos = myPPR.Value
        'If curPos.IsEqualTo(BasePt) Then
        '    Return SamplerStatus.NoChange
        'Else
        myMatrix = Geometry.Matrix3d.Displacement(BasePt.GetVectorTo(myPPR.Value))
        BasePt = myPPR.Value
        Return SamplerStatus.OK
        'End If
    End Function
    Protected Overrides Function Update() As Boolean
        myBRef.Position = BasePt
        Return False
    End Function
End Class

 

I did not go through all the code you showed, but direcctly to your question, it looks like the following code snippet is at faulty:

 

<quote>

    Public Sub InsertBlockWithJig(ByVal blockname As String, layer As String)
        Dim myDB As Database
        myDB = HostApplicationServices.WorkingDatabase
        Dim myJig As BlockJig
        Using myTrans As Transaction = myDB.TransactionManager.StartTransaction
            Dim myBT As BlockTable = myDB.BlockTableId.GetObject(OpenMode.ForRead)
            If myBT.Has(blockname) Then
                Dim myBTR As BlockTableRecord = myBT(blockname).GetObject(OpenMode.ForRead)
                myJig = New BlockJig(New Geometry.Point3d(0, 0, 0), myBTR.ObjectId)
            Else
                Exit Sub
            End If
        End Using
        Dim myBlkID As ObjectId
        Dim SelPt As EditorInput.PromptPointResult
        Do
            SelPt = myJig.BeginJig
            If Not SelPt Is Nothing Then
                Select Case SelPt.Status
                    Case EditorInput.PromptStatus.OK
                        myBlkID = insertblock(BasePt, blockname)
                    Case EditorInput.PromptStatus.Other
                        Exit Sub
                End Select
            End If
            If SelPt Is Nothing Then Exit Do
        Loop While SelPt.Status = EditorInput.PromptStatus.OK
    End Sub

</quote>

 

I did not find where the variable "BasePT" is declared in your code (is it a global variable in your loaded add-in app?), I assume its value is (0.0,0.0,0.0). Thus all block is inserted there, regarless what point is selected by your jig.

 

If the jig's returning status is PromptStatus.OK, then you should use the picked point SelPt.Value instead of BasePt:

 

myBlkId=insertblock(sSelPt.Value, blockName)

*Expert Elite*
norman.yuan
Posts: 1,013
Registered: ‎04-27-2009
Message 2 of 3 (141 Views)

Re: Insert To Point

04-30-2014 10:52 AM in reply to: Ron_M

I did not go through all the code you showed, but direcctly to your question, it looks like the following code snippet is at faulty:

 

<quote>

    Public Sub InsertBlockWithJig(ByVal blockname As String, layer As String)
        Dim myDB As Database
        myDB = HostApplicationServices.WorkingDatabase
        Dim myJig As BlockJig
        Using myTrans As Transaction = myDB.TransactionManager.StartTransaction
            Dim myBT As BlockTable = myDB.BlockTableId.GetObject(OpenMode.ForRead)
            If myBT.Has(blockname) Then
                Dim myBTR As BlockTableRecord = myBT(blockname).GetObject(OpenMode.ForRead)
                myJig = New BlockJig(New Geometry.Point3d(0, 0, 0), myBTR.ObjectId)
            Else
                Exit Sub
            End If
        End Using
        Dim myBlkID As ObjectId
        Dim SelPt As EditorInput.PromptPointResult
        Do
            SelPt = myJig.BeginJig
            If Not SelPt Is Nothing Then
                Select Case SelPt.Status
                    Case EditorInput.PromptStatus.OK
                        myBlkID = insertblock(BasePt, blockname)
                    Case EditorInput.PromptStatus.Other
                        Exit Sub
                End Select
            End If
            If SelPt Is Nothing Then Exit Do
        Loop While SelPt.Status = EditorInput.PromptStatus.OK
    End Sub

</quote>

 

I did not find where the variable "BasePT" is declared in your code (is it a global variable in your loaded add-in app?), I assume its value is (0.0,0.0,0.0). Thus all block is inserted there, regarless what point is selected by your jig.

 

If the jig's returning status is PromptStatus.OK, then you should use the picked point SelPt.Value instead of BasePt:

 

myBlkId=insertblock(sSelPt.Value, blockName)

Valued Contributor
Ron_M
Posts: 68
Registered: ‎12-09-2013
Message 3 of 3 (132 Views)

Re: Insert To Point

04-30-2014 11:31 AM in reply to: norman.yuan

That was it.  Many thanks to you.

Post to the Community

Have questions about Autodesk products? Ask the community.

New Post
Need installation help?

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