|
|
#1 |
|
Full Member
![]() ![]() |
Hi there!
Because i'm still working on my database connection and a user interface i've got another question. My problem is that my routine has to work also with older drawings with old blocks. Old blocks don't have a attribute named "GEA-ID". So I want this to check/add when there is a drawing opened or an object is added. When a drawing is opened: Code:
Sub ACADApp_EndOpen(ByVal FileName As String)
If ThisDrawing.GetVariable("WRITESTAT") = 0 Then
Exit Sub
End If
If Not (Left(ThisDrawing.Name, 1)) = "~" Then
Exit Sub
End If
Call Check_If_CORRECT_GEA_ID_Is_In_Block
End Sub
Sub Check_If_GEA_ID_Is_In_Block() 'Elem, Handle, NewOrNot As Boolean)
Dim attributeObj As AcadAttribute
Dim BlockObj As AcadBlock
Dim InsertionPnt(0 To 2) As Double
For Each Elem In ThisDrawing.ModelSpace
With Elem
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If ((Elem.HasAttributes) And (Left(Elem.EffectiveName, 3) = "G_B") Or (Left(Elem.EffectiveName, 3) = "G_E") Or _
(Left(Elem.EffectiveName, 3) = "G_I") Or (Left(Elem.EffectiveName, 3) = "G_L")) Then
Attributen = Elem.GetAttributes
Found = False
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr 'NODIG???????
For Count = LBound(Attributen) To UBound(Attributen) 'Read attributes from block
If Attributen(Count).TagString = "GEA_ID" Then
Found = True
End If
Next Count
If Found = False Then
Set BlockObj = ThisDrawing.Blocks(Elem.EffectiveName)
InsertionPnt(0) = 0#: InsertionPnt(1) = 0#: InsertionPnt(2) = 0#
Set attributeObj = BlockObj.AddAttribute(1, acAttributeModeInvisible, "GEA_ID", InsertionPnt, "GEA_ID", "")
attributeObj.Layer = "Attrib-Hidden"
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr
ThisDrawing.Regen (acActiveViewport) 'NODIG??
End If
End If
End If
End With
Next Elem
End Sub
For Adding (like copying): Code:
Public Sub AcadDocument_ObjectAdded(ByVal Elem As Object)
Dim Handle As String
Dim Attributen As Variant
Dim Found As Boolean
Dim InsertionPnt(0 To 2) As Double
On Error GoTo ErrHandler
'Renew Handle in GEA_ID Attribute
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr
With Elem
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If ((Elem.HasAttributes) And (Left(Elem.EffectiveName, 3) = "G_B") Or (Left(Elem.EffectiveName, 3) = "G_E") Or _
(Left(Elem.EffectiveName, 3) = "G_I") Or (Left(Elem.EffectiveName, 3) = "G_L")) Then
Attributen = Elem.GetAttributes
Found = False
For Count = LBound(Attributen) To UBound(Attributen) 'Read attributes from block
If Attributen(Count).TagString = "GEA_ID" Then
Found = True
Attributen(Count).TextString = Elem.Handle
End If
Next Count
If Found = False Then
Set BlockObj = ThisDrawing.Blocks(Elem.EffectiveName)
InsertionPnt(0) = 0#: InsertionPnt(1) = 0#: InsertionPnt(2) = 0#
Set attributeObj = BlockObj.AddAttribute(1, acAttributeModeInvisible, "GEA_ID", InsertionPnt, "GEA_ID", "")
attributeObj.Layer = "Attrib-Hidden"
ThisDrawing.SendCommand "_ATTSYNC" & vbCr & "NAME" & vbCr & Elem.EffectiveName & vbCr
ThisDrawing.Regen (acActiveViewport) 'NODIG??
End If
End If
End If
End With
Exit Sub
ErrHandler:
If Err.Number = 438 Then
Exit Sub
Else
MsgBox Err.Number & Err.Description
End If
End Sub
|
|
|
|
![]() |
| Thread Tools | |
|
|
Similar Threads
|
||||
| Thread | Thread Starter | Forum | Replies | Last Post |
| 0s Added When Paste XLS as a Table | ziemerd | AutoCAD Beginners' Area | 1 | 15th Oct 2009 03:08 pm |
| Hatch Around Text Added Later | Bill Tillman | AutoCAD General | 9 | 10th Oct 2009 02:41 am |
| Toolbars cannot be added or removed | jlbuller | AutoCAD General | 9 | 27th Aug 2009 11:57 am |
| After command 'copy': "Autocad message: item added" WHY? | MarcoW | AutoLISP, VBA, the CUI & Customisation | 4 | 25th Aug 2009 12:24 pm |