Attribute
Here is some code that uses the getXX class Library. I've attached the library file.
I've made some small changes to return "ENTER" from the original.
If you want the original it's available here.
http://ingp.ca/index.php?en.SolCAOGetXX
http://dinardiengineering.com/downloads/autodesk.php
---------------------------------------------------------
Simply copy the Attached file into a new class file and call it GetXX
This code will let you pick an attribute and paste it multiple times into another block.
It will exit when you press ESC.
Then use this code in your module.
{code}
Public Sub CopyAtt()
Dim attSource As AcadAttributeReference
Dim attDest As AcadAttributeReference
If getAttribute("Select Source Attribute: ", attSource) Then
While getAttribute("Select Target Attribute: ", attDest)
attDest.TextString = attSource.TextString
attDest.Update
Wend
End If
End Sub
Function getAttribute(ByVal strPrompt As String, ByRef AttObject As AcadAttributeReference) As Boolean
Dim pt As Variant
Dim strHandle As String
Dim attText As String
strHandle = GetSubEntity(strPrompt, pt)
If Not UCase(strHandle) = UCase("ENTER") Then
Set AttObject = ThisDrawing.HandleToObject(strHandle)
If Not TypeOf AttObject Is AcadAttributeReference Then
Call getAttribute(sttprompt, AttObject)
Else
getAttribute = True
Exit Function
End If
End If
End Function
Function GetSubEntity(prompt As String, ByRef pt) As String
Dim GetXX As New GetXX
Dim lError As Long
Set GetXX.Application = Application
GetSubEntity = GetXX.GetSubEntity(lError, pt, , , prompt)
End Function
{code}
I've made some small changes to return "ENTER" from the original.
If you want the original it's available here.
http://ingp.ca/index.php?en.SolCAOGetXX
http://dinardiengineering.com/downloads/autodesk.php
---------------------------------------------------------
Simply copy the Attached file into a new class file and call it GetXX
This code will let you pick an attribute and paste it multiple times into another block.
It will exit when you press ESC.
Then use this code in your module.
{code}
Public Sub CopyAtt()
Dim attSource As AcadAttributeReference
Dim attDest As AcadAttributeReference
If getAttribute("Select Source Attribute: ", attSource) Then
While getAttribute("Select Target Attribute: ", attDest)
attDest.TextString = attSource.TextString
attDest.Update
Wend
End If
End Sub
Function getAttribute(ByVal strPrompt As String, ByRef AttObject As AcadAttributeReference) As Boolean
Dim pt As Variant
Dim strHandle As String
Dim attText As String
strHandle = GetSubEntity(strPrompt, pt)
If Not UCase(strHandle) = UCase("ENTER") Then
Set AttObject = ThisDrawing.HandleToObject(strHandle)
If Not TypeOf AttObject Is AcadAttributeReference Then
Call getAttribute(sttprompt, AttObject)
Else
getAttribute = True
Exit Function
End If
End If
End Function
Function GetSubEntity(prompt As String, ByRef pt) As String
Dim GetXX As New GetXX
Dim lError As Long
Set GetXX.Application = Application
GetSubEntity = GetXX.GetSubEntity(lError, pt, , , prompt)
End Function
{code}
---------------------------
(defun botsbuildbots() (botsbuildbots))
(defun botsbuildbots() (botsbuildbots))
You will need to use ObjectDBX to open the drawing
be sure and check if the file is in use before opening it.
{code}
Public Function getOdbx(ByRef acadApp As Autodesk.AutoCAD.Interop.AcadApplication, ByRef acadDBX As Object, ByVal FileName As String)
Try
acadDBX = acadApp.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
Catch ex As exception
MessageBox.Show("Error Connecting to AutoCAD", "Autocad Message", MessageBoxButtons.OK, MessageBoxIcon.Stop)
End Try
Try
acadDBX.Open(Filename)
' do stuff
acadDBX.saveas(FileName)
Return True
Catch ex As Exception
Return False
End Try
End Function
Public Function isFileInUse(ByVal sFile As String) As Boolean
If System.IO.File.Exists(sFile) Then
Try
Dim F As Short = FreeFile()
FileOpen(F, sFile, OpenMode.Binary, OpenAccess.ReadWrite, OpenShare.LockReadWrite)
FileClose(F)
Catch
Return True
End Try
End If
End Function
{code}
be sure and check if the file is in use before opening it.
{code}
Public Function getOdbx(ByRef acadApp As Autodesk.AutoCAD.Interop.AcadApplication, ByRef acadDBX As Object, ByVal FileName As String)
Try
acadDBX = acadApp.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
Catch ex As exception
MessageBox.Show("Error Connecting to AutoCAD", "Autocad Message", MessageBoxButtons.OK, MessageBoxIcon.Stop)
End Try
Try
acadDBX.Open(Filename)
' do stuff
acadDBX.saveas(FileName)
Return True
Catch ex As Exception
Return False
End Try
End Function
Public Function isFileInUse(ByVal sFile As String) As Boolean
If System.IO.File.Exists(sFile) Then
Try
Dim F As Short = FreeFile()
FileOpen(F, sFile, OpenMode.Binary, OpenAccess.ReadWrite, OpenShare.LockReadWrite)
FileClose(F)
Catch
Return True
End Try
End If
End Function
{code}
---------------------------
(defun botsbuildbots() (botsbuildbots))
(defun botsbuildbots() (botsbuildbots))
You can search though the drawing, find the block, find the Attibute tag and set the text.
without opening the file in the editor.
{code}
Public Sub SetAttribute(ByVal strFileName As String)
Dim strAttTag As String = "SHT_TTL_L2"
Dim strAttText As String = "Some Text"
Dim strBlockName As String = "Ford_A1"
If Not isFileInUse(strFileName) Then
Try
Dim acApp As Autodesk.AutoCAD.Interop.AcadApplication = GetObject(, "AutoCAD.Application.17.2")
Dim doc As AxDbDocument = acApp.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
doc.Open(strFileName)
For Each obj As AcadEntity In doc.ModelSpace
If TypeOf obj Is AcadBlockReference Then
Dim Block As AcadBlockReference = obj
' Check if BlockName matches
If Block.Name.ToUpper = strBlockName.ToUpper Then
If Block.HasAttributes Then
If Block.HasAttributes Then
For Each att As AcadAttributeReference In Block.GetAttributes
If att.TagString = strAttTag Then
' Change Attribute String
att.TextString = strAttText
End If
Next
End If
End If
End If
End If
Next
doc.SaveAs(strFileName)
doc = Nothing
acApp = Nothing
Catch ex As Exception
MsgBox("Error getting Autocad")
End Try
End If
End Sub
{code}
without opening the file in the editor.
{code}
Public Sub SetAttribute(ByVal strFileName As String)
Dim strAttTag As String = "SHT_TTL_L2"
Dim strAttText As String = "Some Text"
Dim strBlockName As String = "Ford_A1"
If Not isFileInUse(strFileName) Then
Try
Dim acApp As Autodesk.AutoCAD.Interop.AcadApplication = GetObject(, "AutoCAD.Application.17.2")
Dim doc As AxDbDocument = acApp.GetInterfaceObject("ObjectDBX.AxDbDocument.17")
doc.Open(strFileName)
For Each obj As AcadEntity In doc.ModelSpace
If TypeOf obj Is AcadBlockReference Then
Dim Block As AcadBlockReference = obj
' Check if BlockName matches
If Block.Name.ToUpper = strBlockName.ToUpper Then
If Block.HasAttributes Then
If Block.HasAttributes Then
For Each att As AcadAttributeReference In Block.GetAttributes
If att.TagString = strAttTag Then
' Change Attribute String
att.TextString = strAttText
End If
Next
End If
End If
End If
End If
Next
doc.SaveAs(strFileName)
doc = Nothing
acApp = Nothing
Catch ex As Exception
MsgBox("Error getting Autocad")
End Try
End If
End Sub
{code}
---------------------------
(defun botsbuildbots() (botsbuildbots))
(defun botsbuildbots() (botsbuildbots))
Laurie Comerford,
I would also like to point out that the caller switched his language from VBA to .net.
Sorry, I didn't want to upset the VBA Temple Guards. The angry horde is at the gate.
If you look at the code HE offered you will see this is vb.net code and not VBA
{code}
Imports Autodesk.AutoCAD.Interop
Imports System.Data.Common
Imports Autodesk.AutoCAD.Interop.Common
{code}
I would also like to point out that the caller switched his language from VBA to .net.
Sorry, I didn't want to upset the VBA Temple Guards. The angry horde is at the gate.
If you look at the code HE offered you will see this is vb.net code and not VBA
{code}
Imports Autodesk.AutoCAD.Interop
Imports System.Data.Common
Imports Autodesk.AutoCAD.Interop.Common
{code}
---------------------------
(defun botsbuildbots() (botsbuildbots))
(defun botsbuildbots() (botsbuildbots))
Your Welcome.
I noticed that Autocad will not Release the file once it has been modified with ObjectDBX
I had to close Autocad.
This will release the file when it is finished
{code}
Public Sub runCode()
Dim strFilename = ("c:\test.dwg")
If Not isFileInUse(strFileName) Then
SetAttribute (strFileName)
End If
End Sub
Public Function SetAttribute(ByVal strFileName As String) As Boolean
Dim BT As BlockTable
Dim Btr As BlockTableRecord
Dim ent As entity
Dim bDwg As New Database(False, True)
Dim rtnValue As Boolean
Dim strAttTag As String = "SHT_TTL_L2"
Dim strAttText As String = "SOMETEXT"
Dim strBlockName As String = "Ford_A1"
bDwg.ReadDwgFile(strFileName, System.IO.FileShare.ReadWrite, True, "")
Dim db As Database = bDwg
Dim tr As Autodesk.AutoCAD.DatabaseServices.TransactionManager = bDwg.TransactionManager
Using tr.StartTransaction()
' get Block table
BT = CType(db.BlockTableId.GetObject(DatabaseServices.OpenMode.ForWrite), BlockTable)
' get Modelspace
Btr = CType(BT(BlockTableRecord.ModelSpace).GetObject(OpenMode.ForWrite), BlockTableRecord)
' get Iteration for modelspace
Dim iter As BlockTableRecordEnumerator = Btr.GetEnumerator
While iter.MoveNext
' get each object in the modelspace
ent = iter.Current.GetObject(OpenMode.ForRead)
If TypeOf ent Is BlockReference Then
Dim Block As BlockReference = ent
' Check if the block name matches
If Block.name = strBlockName Then
For Each Id As ObjectId In Block.AttributeCollection
' get Attribute
Dim AttEnt As Entity = Id.GetObject(Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite)
' Check each Attribute for matching name
If TypeOf AttEnt Is AttributeReference Then
Dim attRef As AttributeReference = AttEnt
If attRef.Tag = strAttTag Then
' Change text String
attRef.TextString = strAttText
' Save Changes
bDwg.SaveAs(strFileName, DwgVersion.Current)
' Set Return value
rtnValue = True
' get out of the loop
Exit While
End If
End If
Next
End If
End If
End While
End Using
' Close File
bDwg.CloseInput (True)
' Release file inuse
bDwg.Dispose()
' Clear Reference
bDwg = Nothing
' Return Value
Return rtnValue
End Function
{code}
I noticed that Autocad will not Release the file once it has been modified with ObjectDBX
I had to close Autocad.
This will release the file when it is finished
{code}
Public Sub runCode()
Dim strFilename = ("c:\test.dwg")
If Not isFileInUse(strFileName) Then
SetAttribute (strFileName)
End If
End Sub
Public Function SetAttribute(ByVal strFileName As String) As Boolean
Dim BT As BlockTable
Dim Btr As BlockTableRecord
Dim ent As entity
Dim bDwg As New Database(False, True)
Dim rtnValue As Boolean
Dim strAttTag As String = "SHT_TTL_L2"
Dim strAttText As String = "SOMETEXT"
Dim strBlockName As String = "Ford_A1"
bDwg.ReadDwgFile(strFileName, System.IO.FileShare.ReadWrite, True, "")
Dim db As Database = bDwg
Dim tr As Autodesk.AutoCAD.DatabaseServices.TransactionManager = bDwg.TransactionManager
Using tr.StartTransaction()
' get Block table
BT = CType(db.BlockTableId.GetObject(DatabaseServices.OpenMode.ForWrite), BlockTable)
' get Modelspace
Btr = CType(BT(BlockTableRecord.ModelSpace).GetObject(OpenMode.ForWrite), BlockTableRecord)
' get Iteration for modelspace
Dim iter As BlockTableRecordEnumerator = Btr.GetEnumerator
While iter.MoveNext
' get each object in the modelspace
ent = iter.Current.GetObject(OpenMode.ForRead)
If TypeOf ent Is BlockReference Then
Dim Block As BlockReference = ent
' Check if the block name matches
If Block.name = strBlockName Then
For Each Id As ObjectId In Block.AttributeCollection
' get Attribute
Dim AttEnt As Entity = Id.GetObject(Autodesk.AutoCAD.DatabaseServices.OpenMode.ForWrite)
' Check each Attribute for matching name
If TypeOf AttEnt Is AttributeReference Then
Dim attRef As AttributeReference = AttEnt
If attRef.Tag = strAttTag Then
' Change text String
attRef.TextString = strAttText
' Save Changes
bDwg.SaveAs(strFileName, DwgVersion.Current)
' Set Return value
rtnValue = True
' get out of the loop
Exit While
End If
End If
Next
End If
End If
End While
End Using
' Close File
bDwg.CloseInput (True)
' Release file inuse
bDwg.Dispose()
' Clear Reference
bDwg = Nothing
' Return Value
Return rtnValue
End Function
{code}
---------------------------
(defun botsbuildbots() (botsbuildbots))
(defun botsbuildbots() (botsbuildbots))