VB.Net version of VPlayerOff -
Hi all, Trying to convert the popular VB VPlayerOff function to VB.Net with added functionality of turning a layer off in all viewports in a layout. My code seems to do everything right except update the Xdata with the new results. I tried manipulating the Xdata result buffer initially but is said it was read only so that is why I have done it this way.I will post the Xdata functions from "From Jerry Winters AU 2009 Class - "Store it in the DWG: XData, Extension Dictionaries and Object Data Through .NET"in a separate post since I went over my allotted 15000 charaters.
Note, Current code needs an object on a layer called 'test' in drawing file, with something in the layer .
Thanks
Mike
PS - first time posting so hope I did this right!
Imports Autodesk.AutoCAD.InteropImports Autodesk.AutoCAD.Interop.CommonImports Autodesk.AutoCAD.RuntimeImports Autodesk.AutoCADImports Autodesk.AutoCAD.DatabaseServicesImports Autodesk.AutoCAD.EditorInputImports Autodesk.AutoCAD.GeometryImports Autodesk.AutoCAD.ApplicationServicesImports Autodesk.AutoCAD.ApplicationServices.ApplicationImports Autodesk.AutoCAD.LayerManagerImports Autodesk.AutoCAD.WindowsPublic Class vbTools _Public Sub VPLOFF()Dim myDB As Database = HostApplicationServices.WorkingDatabaseUsing myTrans As Transaction = myDB.TransactionManager.StartTransactionDim myBT As BlockTable = myDB.BlockTableId.GetObject(OpenMode.ForWrite)For Each myBtrID As ObjectId In myBTDim myBTR As BlockTableRecord = myBtrID.GetObject(OpenMode.ForWrite)If myBTR.IsLayout = True Then Dim myLayout As Layout = myBTR.LayoutId.GetObject(OpenMode.ForWrite) Dim myLayoutString As String = myLayout.LayoutName Dim myVPIDs As ObjectIdCollection = myLayout.GetViewports() For Each myVPortID As ObjectId In myVPIDs Dim myVP As Viewport = DirectCast(myTrans.GetObject(myVPortID, OpenMode.ForWrite), Viewport) DocumentManager.MdiActiveDocument.Editor.WriteMessage(myVP.Layer + vbNewLine) VpLayerOff("test", myVPortID) myVP.UpdateDisplay() NextEnd IfNextEnd UsingEnd SubSub VpLayerOff(ByVal myVpLyrName As String, ByRef myVPID As ObjectId)Dim I As IntegerDim Counter As IntegerDim myResBuff As ResultBuffer = GetXData(myVPID, "ACAD")Dim myNewResBuff As New ResultBufferIf myResBuff Is Nothing = False ThenFor I = LBound(myResBuff.AsArray) To UBound(myResBuff.AsArray)'debug print out XdataDocumentManager.MdiActiveDocument.Editor.WriteMessage(myResBuff.AsArray(I).TypeCode & vbTab & myResBuff.AsArray(I).Value.ToString & vbNewLine)If myResBuff.AsArray(I).TypeCode = 1003 Then Counter = I + 1 If myResBuff.AsArray(I).Value.ToString = myVpLyrName Then Exit Sub End IfEnd IfNextElseMsgBox("NO XData under that AppName.")End IfIf Counter = 0 ThenFor I = LBound(myResBuff.AsArray) To UBound(myResBuff.AsArray)If myResBuff.AsArray(I).TypeCode = 1002 Then Counter = I - 1End IfNextEnd If'adds existing data to the new result buffer we are creatingFor I = LBound(myResBuff.AsArray) To Counter - 1myNewResBuff.Add(New TypedValue(myResBuff.AsArray(I).TypeCode, myResBuff.AsArray(I).Value))Next'appends the new frozen layer and closes the setmyNewResBuff.Add(New TypedValue(1003, myVpLyrName))myNewResBuff.Add(New TypedValue(1002, "}"))myNewResBuff.Add(New TypedValue(1002, "}"))'debug display to see new record bufferDocumentManager.MdiActiveDocument.Editor.WriteMessage(vbNewLine & vbNewLine)For I = LBound(myNewResBuff.AsArray) To UBound(myNewResBuff.AsArray)'debug print out XdataDocumentManager.MdiActiveDocument.Editor.WriteMessage(myNewResBuff.AsArray(I).TypeCode & vbTab & myNewResBuff.AsArray(I).Value.ToString & vbNewLine)NextAddXData(myVPID, myNewResBuff)End SubEnd Class As promised here are the Jerry Winters Functions that goes into the Class
'From Jerry Winters AU 2009 Class - "Store it in the DWG: XData,'Extension Dictionaries and Object Data Through .NETFunction GetXData(ByVal EntityID As ObjectId, ByVal AppName As String) As ResultBufferUsing myTrans As Transaction = EntityID.Database.TransactionManager.StartTransactionDim selEnt As Entity = EntityID.GetObject(OpenMode.ForRead)Dim myResBuffer As ResultBuffer = selEnt.GetXDataForApplication(AppName)Return myResBufferEnd UsingEnd Function 'From Jerry Winters AU 2009 Class - "Store it in the DWG: XData,'Extension Dictionaries and Object Data Through .NETSub AddXData(ByVal EntityID As ObjectId, ByVal BufferIn As ResultBuffer)AddXDataApp(BufferIn.AsArray(0).Value)Using myTrans As Transaction = EntityID.Database.TransactionManager.StartTransaction Dim selEnt As Entity = EntityID.GetObject(OpenMode.ForWrite) selEnt.XData = BufferIn myTrans.Commit()End UsingEnd Sub 'From Jerry Winters AU 2009 Class - "Store it in the DWG: XData,'Extension Dictionaries and Object Data Through .NETSub AddXDataApp(ByVal AppName As String)Dim myDWG As Document = DocumentManager.MdiActiveDocumentUsing myTrans As Transaction = myDWG.TransactionManager.StartTransaction 'Add the XData ApplicationName Dim myAppTable As RegAppTable = myDWG.Database.RegAppTableId.GetObject(OpenMode.ForWrite) If myAppTable.Has(AppName) = False Then Dim myAppTableRecord As New RegAppTableRecord myAppTableRecord.Name = AppName myAppTable.Add(myAppTableRecord) myTrans.AddNewlyCreatedDBObject(myAppTableRecord, True) End If myTrans.Commit()End UsingEnd Sub
页:
[1]