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
Solved! Go to Solution.
Solved by norman.yuan. Go to Solution.
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)
Norman Yuan
Can't find what you're looking for? Ask the community or share your knowledge.