Message 1 of 13
Not applicable
05-02-2014
08:00 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
ACA 2014, WIndows 7 64, VS 2013 Express, VB.Net
The block library is coming along well and I'm at a point where one further push or assist should allow me to complete it.
At this time blocks are pulled from external drawings, shown on the cursor as it moves on the screen, rotate on the cursor prior to input, BUT insert at the original orientation. I am confused on how to pass back to InsertBlock the rotation angle of the block as shown on the cursor and have the block inserted at that orienation rather than at the original. Below are the code for my library and the jig.
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
Dim layer As String
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
layer = (fields(box))
Finally
End Try
End While
AddLayer(layer)
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(layer)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
acDoc.LockDocument()
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim ltb As LayerTable = DirectCast(tr.GetObject(db.LayerTableId, OpenMode.ForRead), LayerTable)
'create a new layer
If Not ltb.Has(layer) Then
ltb.UpgradeOpen()
Dim newLayer As New LayerTableRecord()
newLayer.Name = layer
newLayer.LineWeight = LineWeight.LineWeight005
newLayer.Description = "This is new layer"
'red color
newLayer.Color = Autodesk.AutoCAD.Colors.Color.FromRgb(255, 0, 0)
ltb.Add(newLayer)
tr.AddNewlyCreatedDBObject(newLayer, True)
End If
tr.Commit()
'make it as current
db.Clayer = ltb(layer)
End Using
End Sub
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(myBTR.ObjectId)
Else
Exit Sub
End If
End Using
Dim myBlkID As ObjectId
Dim SelPt As EditorInput.PromptPointResult
Dim pdr As EditorInput.PromptPointResult
Do
SelPt = myJig.BeginJig
If Not SelPt Is Nothing Then
Select Case SelPt.Status
Case EditorInput.PromptStatus.OK
myBlkID = insertblock(SelPt.Value, 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 ClassBlockJig.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
Protected _pos As Point3d
Protected _rot As Double, _ucsRot As Double
Sub New(ByVal BlockID As ObjectId)
MyBase.New(New DatabaseServices.BlockReference(BlockIns, BlockID))
myBRef = Me.Entity
_pos = myBRef.Position
_rot = myBRef.Rotation
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
Dim ucs As CoordinateSystem3d = ed.CurrentUserCoordinateSystem.CoordinateSystem3d
Dim ocsMat As Matrix3d = Matrix3d.WorldToPlane(New Plane(Point3d.Origin, ucs.Zaxis))
_ucsRot = Vector3d.XAxis.GetAngleTo(ucs.Xaxis.TransformBy(ocsMat), ucs.Zaxis)
_rot = myBRef.Rotation - _ucsRot
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(prompts As JigPrompts) As SamplerStatus
Dim mods As System.Windows.Forms.Keys = System.Windows.Forms.Control.ModifierKeys
If (mods And System.Windows.Forms.Keys.Control) > 0 Then
Dim jpao As New JigPromptAngleOptions(vbLf & "Specify the rotation: ")
jpao.UseBasePoint = True
jpao.BasePoint = myBRef.Position
jpao.Cursor = CursorType.Invisible
jpao.UserInputControls = (UserInputControls.Accept3dCoordinates Or UserInputControls.UseBasePointElevation)
Dim pdr As PromptDoubleResult = prompts.AcquireAngle(jpao)
If _rot = pdr.Value Then
Return SamplerStatus.NoChange
Else
_rot = pdr.Value
Return SamplerStatus.OK
End If
Else
Dim jppo As New JigPromptPointOptions(vbLf & "Specify insertion point (or press Ctrl for rotation): ")
jppo.UserInputControls = (UserInputControls.Accept3dCoordinates Or UserInputControls.NullResponseAccepted)
Dim ppr As PromptPointResult = prompts.AcquirePoint(jppo)
If _pos.DistanceTo(ppr.Value) < Tolerance.[Global].EqualPoint Then
Return SamplerStatus.NoChange
Else
_pos = ppr.Value
End If
Return SamplerStatus.OK
End If
End Function
Protected Overrides Function Update() As Boolean
myBRef.Position = _pos
myBRef.Rotation = _rot + _ucsRot
Return True
End Function
End Class
Solved! Go to Solution.
