Alfred,
ich habe das Gerade probiert. set Annotation=nothing im Eventhandler. Dann ist zwar die Objektvariable nicht mehr ggesetzt, das Objekt selbst ab er immer noch vor dem Schreiben geschützt.Der Code stürzt wieder beim Schreiben des Attributreftextes ab, mit der gleichen Fehlermeldung.
Ich hoffe, ich habe auch richtig verstanden was du wolltest. Heisst das jetzt, dass der Eventhandler generell auf das den Event auslösende Objekt nur Lesezugriff hat?
Als Anhang nochmal der Code.
Gruss,
Christian
Option Explicit
Public WithEvents ACADApp As AcadApplication
Public ksGlobalSettings As New Ks_ComGlobalSettings
Public ksApplication As New Ks_ComApplication
Public WithEvents Annotation As AcadBlockReference
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' On Acadstart
Sub ACADStartup()
Dim ksGlobalSettings As New Ks_ComGlobalSettings
MsgBox "Start AutoCad"
Set ACADApp = GetObject(, "AutoCAD.Application.17")
ThisDrawing.SetVariable "DEMANDLOAD", 2
ThisDrawing.SetVariable "PICKSTYLE", 0
ThisDrawing.SetVariable "Savetime", 3
ThisDrawing.SetVariable "UCSICON", 3
'set Pickhelper
ksGlobalSettings.PickHelperSize = 3
ksGlobalSettings.PickHelperStatus = True
ksGlobalSettings.PickHelperColor = 80
End Sub
Private Sub ACADApp_EndSave(ByVal FileName As String)
Dim AcSelectionset As AcadSelectionSet
Dim FTyp(1) As Integer, FVal(1) As Variant
Dim Filter1, Filter2 As Variant
Err.Clear
On Error Resume Next
Set AcSelectionset = ThisDrawing.SelectionSets.Item("Annotation")
If Err.Number <> 0 Then
Set AcSelectionset = ThisDrawing.SelectionSets.Add("Annotation")
End If
AcSelectionset.Clear
FTyp(0) = 0: FVal(0) = "INSERT"
FTyp(1) = 2: FVal(1) = "stamp_2"
Filter1 = FTyp: Filter2 = FVal
AcSelectionset.Select acSelectionSetAll, , , Filter1, Filter2
If AcSelectionset.Count = 0 Then
Exit Sub
End If
Set Annotation = AcSelectionset.Item(0)
End Sub
Private Sub Annotation_Modified(ByVal pObject As AutoCAD.IAcadObject)
MsgBox "You just modified an object with an ID of: " & pObject.ObjectID
Set Annotation = Nothing
add_Stampdata1
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' On NewDrawing
Private Sub ACADApp_NewDrawing()
Dim ksGlobalSettings As New Ks_ComGlobalSettings
MsgBox "A request to start a new drawing was just intercepted!"
ThisDrawing.SetVariable "PICKSTYLE", 0
'set Pickhelper
ksGlobalSettings.PickHelperSize = 3
ksGlobalSettings.PickHelperStatus = True
ksGlobalSettings.PickHelperColor = 80
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' On EndOpenDrawing
Private Sub ACADApp_EndOpen(ByVal FileName As String)
Dim AcSelectionset As AcadSelectionSet
Dim FTyp(1) As Integer, FVal(1) As Variant
Dim Filter1, Filter2 As Variant
MsgBox FileName + " was opened"
ThisDrawing.SetVariable "PICKSTYLE", 0
ThisDrawing.SetVariable "UCSICON", 3
'set Pickhelper
ksGlobalSettings.PickHelperSize = 3
ksGlobalSettings.PickHelperStatus = True
ksGlobalSettings.PickHelperColor = 80
Err.Clear
On Error Resume Next
Set AcSelectionset = ThisDrawing.SelectionSets.Item("Annotation")
If Err.Number <> 0 Then
Set AcSelectionset = ThisDrawing.SelectionSets.Add("Annotation")
End If
AcSelectionset.Clear
FTyp(0) = 0: FVal(0) = "INSERT"
FTyp(1) = 2: FVal(1) = "stamp_2"
Filter1 = FTyp: Filter2 = FVal
AcSelectionset.Select acSelectionSetAll, , , Filter1, Filter2
If AcSelectionset.Count = 0 Then
Exit Sub
End If
Set Annotation = AcSelectionset.Item(0)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' On Activation
Private Sub AcadDocument_activate()
'MsgBox "Hello"
ThisDrawing.SetVariable "UCSICON", 3
End Sub
'Die Stamp annotation modified
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' On BeginClose drawing
Private Sub AcadDocument_BeginDocClose(Cancel As Boolean)
'check ScaleData
add_Scaledata
'Hide Pickhelper
ksGlobalSettings.PickHelperSize = 3
ksGlobalSettings.PickHelperStatus = False
ksGlobalSettings.PickHelperColor = 80
ThisDrawing.Regen acActiveViewport
MsgBox "Say GoodBye"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'ScaleData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub add_Scaledata()
Dim Entity As AcadEntity
Dim CompareEntity As AcadEntity
Dim Handle As String
Dim CompareHandle As String
Dim Check As Boolean
Dim I As Long
Dim K As Long
Dim L As Long
Dim M As Long
Dim N As Long
Dim ksSelection As New Ks_ComSelection
Dim ksPickSelection As New Ks_ComSelection
Dim Result As Long
Dim AcSelectionset As AcadSelectionSet
Dim Layer As AcadLayer
Dim Prompt As String
Dim kwordList As String
Dim strEnter As String
Dim Posnumber As String
Dim visibility As Boolean
Dim GroupWeight As Double
Dim FTyp(1) As Integer, FVal(1) As Variant
Dim Filter1, Filter2 As Variant
Dim Point As Variant
Dim Blockref As AcadBlockReference
Dim Blockrefs(0) As Variant
Dim ksPoint As New Ks_ComPoint
Dim StartPt As Variant
Dim EndPt As Variant
Dim InsertPt As Variant
Dim Attref As AcadAttributeReference
Dim varAttributes As Variant
Dim Tag As String
Dim Part1, Part2 As String
Dim Textobj As AcadText
Dim DwgScale As String
Dim Titlefield As String
Err.Clear
On Error Resume Next
Set AcSelectionset = ThisDrawing.SelectionSets.Item("Scale")
If Err.Number <> 0 Then
Set AcSelectionset = ThisDrawing.SelectionSets.Add("Scale")
End If
AcSelectionset.Clear
FTyp(0) = 0: FVal(0) = "INSERT"
FTyp(1) = 2: FVal(1) = "NOIKRS-TITFLD"
Filter1 = FTyp: Filter2 = FVal
AcSelectionset.Select acSelectionSetAll, , , Filter1, Filter2
If AcSelectionset.Count = 0 Then
End
End If
'
DwgScale = ""
Titlefield = ""
ksSelection.Initialize
ksPickSelection.Initialize
Result = ksSelection.SelectAllObjects
If Result = 0 Then
Exit Sub
End If
For I = ksSelection.ObjectCount - 1 To 0 Step -1
Set Entity = ksSelection.GetObject(I)
M = 0
N = 0
If Entity.Objectname = "AcDbBlockReference" Then
Set Blockref = Entity
If Blockref.Name = "NOIKRS-TITFLD" Then
N = 1
get_Scale DwgScale, ksSelection
If DwgScale = "" Then
MsgBox "there was no scale in the text"
Exit Sub
End If
varAttributes = Blockref.GetAttributes
For K = 0 To UBound(varAttributes)
Set Attref = varAttributes(K)
If Attref.TagString = "SCALE" Then
Attref.TextString = "1:" + CStr(DwgScale)
M = 1
Exit For
End If
Next K
If M = 1 Then
Exit For
End If
End If
End If
Next I
If Not DwgScale = "" Then
MsgBox "Scale set to 1:" + CStr(DwgScale)
End If
If N = 0 Then
MsgBox "there is no titlefield in the drawing"
End If
End Sub
Sub get_Scale(ByRef DwgScale As String, ByRef ksSelection As Ks_ComSelection)
Dim Entity As AcadEntity
Dim CompareEntity As AcadEntity
Dim Handle As String
Dim CompareHandle As String
Dim Check As Boolean
Dim I As Long
Dim K As Long
Dim L As Long
Dim M As Long
Dim N As Long
Dim ksPickSelection As New Ks_ComSelection
Dim Result As Long
Dim AcSelectionset As AcadSelectionSet
Dim Layer As AcadLayer
Dim Prompt As String
Dim kwordList As String
Dim strEnter As String
Dim Posnumber As String
Dim visibility As Boolean
Dim GroupWeight As Double
Dim FTyp(1) As Integer, FVal(1) As Variant
Dim Filter1, Filter2 As Variant
Dim Point As Variant
Dim Blockref As AcadBlockReference
Dim Blockrefs(0) As Variant
Dim ksPoint As New Ks_ComPoint
Dim StartPt As Variant
Dim EndPt As Variant
Dim InsertPt As Variant
Dim Attref As AcadAttributeReference
Dim varAttributes As Variant
Dim Tag As String
Dim Part1, Part2 As String
Dim Textobj As AcadText
Dim Titlefield As String
For I = 0 To ksSelection.ObjectCount - 1
Set Entity = ksSelection.GetObject(I)
DwgScale = ""
M = 0
If Entity.Objectname = "AcDbText" Then
Set Textobj = Entity
DwgScale = Textobj.TextString
If Left$(DwgScale, 5) = "Group" Then
If Right$(DwgScale, 1) = ")" Then
For K = Len(DwgScale) - 6 To 1 Step -1
If Mid$(DwgScale, K, 5) = "(Sc1:" Then
DwgScale = Mid$(DwgScale, K + 5, Len(DwgScale) - 1 - K - 4)
M = 1
For L = 1 To Len(DwgScale)
If 48 > Asc(Mid$(DwgScale, L, 1)) Or 57 < Asc(Mid$(DwgScale, L, 1)) Then
M = 0
Exit For
End If
Next L
End If
Next K
If M = 0 Then
DwgScale = ""
End If
Else
DwgScale = ""
End If
Else
DwgScale = ""
End If
End If
If M = 1 Then
Exit For
End If
Next I
Debug.Print DwgScale + vbCrLf
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If DwgScale = "" Then
MsgBox "pick text to read scale from"
Set Entity = ksPickSelection.PickObject("", Result)
If Result = 0 Then
Exit Sub
End If
If Entity.Objectname = "AcDbText" Then
Set Textobj = Entity
DwgScale = Textobj.TextString
N = 0
For K = Len(DwgScale) - 6 To 1 Step -1
If Mid$(DwgScale, K, 5) = "(Sc1:" Then
For L = K + 5 To Len(DwgScale)
If Mid$(DwgScale, L, 1) = ")" Then
DwgScale = Mid$(DwgScale, K + 5, L - 1 - K - 4)
N = 1
For M = 1 To Len(DwgScale)
If 48 > Asc(Mid$(DwgScale, M, 1)) Or 57 < Asc(Mid$(DwgScale, M, 1)) Then
N = 0
Exit For
End If
Next M
End If
Next L
End If
Next K
If N = 0 Then
DwgScale = ""
End If
End If
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'ScaleData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub add_Stampdata1()
Dim Entity As AcadEntity
Dim LastEntity As AcadEntity
Dim CompareEntity As AcadEntity
Dim Handle As String
Dim CompareHandle As String
Dim StringArray As Variant
Dim Check As Boolean
Dim I As Long
Dim K As Long
Dim L As Long
Dim M As Long
Dim N As Long
Dim ksSelection As New Ks_ComSelection
Dim ksMPSelection As New Ks_ComSelection
Dim Result As Long
Dim ksGroup As New Ks_ComObjectGroup
Dim ksGroupProperty As New Ks_ComGroupProperty
Dim ksLastGroupProperty As New Ks_ComGroupProperty
Dim GroupPosnumberArray() As Variant
Dim Layer As AcadLayer
Dim Prompt As String
Dim kwordList As String
Dim strEnter As String
Dim Posnumber As String
Dim visibility As Boolean
Dim GroupWeight As Double
Dim AcSelectionset As AcadSelectionSet
Dim FTyp(1) As Integer, FVal(1) As Variant
Dim Filter1, Filter2 As Variant
Dim Point As Variant
Dim Blockref As AcadBlockReference
Dim Blockrefs(0) As Variant
Dim ksPoint As New Ks_ComPoint
Dim StartPt As Variant
Dim EndPt As Variant
Dim InsertPt As Variant
Dim Attref As AcadAttributeReference
Dim varAttributes As Variant
Dim Tag As String
Dim Part1 As String
Dim Part2 As String
Dim Part3 As String
Dim Textobj As AcadText
Dim DwgScale As String
Dim Titlefield As String
Dim ksGlobalSettings As New Ks_ComGlobalSettings
DwgScale = ""
Titlefield = ""
Part1 = ""
Part2 = ""
Part3 = ""
N = 0
Check = True
Set Annotation = Nothing
Err.Clear
On Error Resume Next
Set AcSelectionset = ThisDrawing.SelectionSets.Item("DieStamp")
If Err.Number <> 0 Then
Set AcSelectionset = ThisDrawing.SelectionSets.Add("DieStamp")
End If
AcSelectionset.Clear
FTyp(0) = 0: FVal(0) = "INSERT"
FTyp(1) = 2: FVal(1) = "stamp_2"
Filter1 = FTyp: Filter2 = FVal
AcSelectionset.Select acSelectionSetAll, , , Filter1, Filter2
If AcSelectionset.Count = 0 Then
MsgBox "There is no die stamp in the drawing"
End
End If
get_Stampparts ThisDrawing.Name, Part1, Part2, Part3
'get groups
ksMPSelection.Initialize
ksSelection.Initialize
ksSelection.SetSelectionFilter kFilterAllSteel
ksSelection.SelectAllObjects
For I = 0 To ksSelection.ObjectCount - 1
Set Entity = ksSelection.GetObject(I)
ksGroupProperty.ReadFrom Entity
If ksGroupProperty.Count > 0 Then
If ksGroupProperty.IsMainPart = True Then
ksMPSelection.AddObject Entity
If ksMPSelection.ObjectCount = 1 Then
ReDim Preserve GroupPosnumberArray(0)
GroupPosnumberArray(0) = ksGroupProperty.Posnumber
Else
ReDim Preserve GroupPosnumberArray(UBound(GroupPosnumberArray) + 1)
GroupPosnumberArray(UBound(GroupPosnumberArray)) = ksGroupProperty.Posnumber
End If
End If
End If
Next I
For I = 1 To UBound(GroupPosnumberArray)
If Not GroupPosnumberArray(I - 1) = GroupPosnumberArray(I) Then
Check = False
MsgBox "GroupPosnumbers are not unambiguous"
End
End If
Next I
If Not CLng(Trim(Part2)) = CLng(GroupPosnumberArray(0)) Then
MsgBox "Groupposnumber and Drawingname do not match"
End
End If
Set Blockref = AcSelectionset.Item(0)
varAttributes = Blockref.GetAttributes
For K = 0 To UBound(varAttributes)
Set Attref = varAttributes(K)
If Attref.TagString = "TEST1" Then
Attref.TextString = Part1 & "-"
ElseIf Attref.TagString = "TEST2" Then
If Not Part3 = "" Then
Attref.TextString = Part2 & "-"
Else
Attref.TextString = Part2
End If
End If
Next K
'ksGlobalSettings.PickHelperStatus = True
End Sub
Sub get_Stampparts(ByRef Drawingname As String, ByRef Part1 As String, ByRef Part2 As String, ByRef Part3 As String) 'ByRef Drawingname
Dim StringArray As Variant
Dim K As Long
If Left$(Drawingname, 1) = "(" Then
K = InStr(Drawingname, ")")
Drawingname = Right(Drawingname, Len(Drawingname) - K)
End If
' remove .dwg
Drawingname = Left(Drawingname, Len(Drawingname) - 4)
'split name into parts
StringArray = Split(Drawingname, "-")
'Check parts and assign
StringArray(0) = Trim(StringArray(0))
Err.Clear
On Error Resume Next
If CLng(Right(StringArray(0), Len(StringArray(0)) - 1)) Then
If Err.Number <> 0 Then
MsgBox "drawingname is not valid"
End
End If
StringArray(1) = Trim(StringArray(1))
If Not StringArray(1) = "D1108" Then
MsgBox "drawingname is not valid"
End
End If
StringArray(2) = Trim(StringArray(2))
Err.Clear
On Error Resume Next
If CLng(StringArray(2)) Then
If Err.Number <> 0 Then
MsgBox "drawingname is not valid"
End
End If
If Not Right(StringArray(2), 1) = "0" Then
Part1 = StringArray(0)
Part2 = StringArray(2)
Else
MsgBox "drawingname is not valid"
End
End If
End If
End If
Debug.Print Part1 + vbCrLf + Part2 + vbCrLf
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
