Hi
Ja natürlich kann man das, wenn auch mit gelindem Aufwand
Man kann jede gewünschte Information als XDATA oder Extended Dictionary an JEDES Autocad Element anhängen.
In deinem Falle ist es nur ne Frage wie du die Daten organisierst.
Ich würde mir das wie ne Excel Tabelle Vorstellen mitjedem Segment als Zeile und den Daten als Spaltenüberschriften.
Eine sehr einfache Möglichkeit ist, diese Datensätze im CSV oder besser TSV Format in einem String vorzuhalten.
Das lässt sich sehr einfach erzeugen und genauso einfach wieder in Datensätze zerlegen.
XDATAS haben die unangenehme Eigenschaft das Audit lange Datenblöcke nicht in der Zeichnung belässt.
Sie eignen sich somit nur für sowas wie "Positionsnummern"
. Immerhin kann man nach ihnen mit nem Selectionset suchen.
Den CSV String würde ich demzufolge einem Dictionary anvertrauen.
Der Haken n dieser Lösung ist lediglich, das wenn die Polylinie gelöscht wird die Daten futsch sind. Oder falls man sie kopiert doppelt vorhanden sind.
Das Spiel kann man aber auch mit der DWG selbst machen. Sprich die gesamte Datenbank per dictionary in oder an die Zeichnung kleben. Das wird mit abgespeichert.
Meine Vorgehensweise st dabei
Tabellen mit VBCR, Zeilen mit VBLF und Spalten mit vbtab zu separieren.
Jetzt muss man nur noch die Polylinien verazten.
Ich benutze hierzu GUIDS. Handles sind nicht das Mittel der Wahl, da auch die sich verändern können. Die sind in diesem Universum lt. Microsoft einzigartig...
Eignen sich also hervorragend dazu um per extended Dictionary an die Polylinie geklebt zu werden.
Nun müssen wir nur noch ne Möglichkeit schaffen, diese besonderen Polylinien in der Zeichnung zu finden.
Das würde ich mit XDATAs Machen.
EInmal einen APPNAMEN für deine Anwenung erzeugen und einmal ANWENDUNGSNAME verkettet mit GUID.
Dann kann man die schön danach auswählen.
Da das ganze nicht so ganz trivial ist hab ich ein paar Routinen beigefügt.
Lieben Gruß
#If Win64 Then
Private Declare PtrSafe Function CoCreateGuid Lib "ole32.dll" (pGuid As GUID) As Long
Private Declare PtrSafe Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Long) As Long
Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As String, ByVal lpiid As Long) As Long
#Else
Private Declare Function CoCreateGuid Lib "ole32.dll" (pGuid As GUID) As Long
Private Declare Function StringFromGUID2 Lib "ole32.dll" (rguid As Any, ByVal lpstrClsId As Long, ByVal cbMax As Long) As Long
Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As String, ByVal lpiid As Long) As Long
#End If
'Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
Public Function NewGUID(Optional braces As Boolean = True) As String
Dim uid As GUID
Dim i As Long
CoCreateGuid uid
NewGUID = _
hex0(uid.data1, 8) & "-" & _
hex0(uid.data2, 4) & "-" & _
hex0(uid.data3, 4) & "-" & _
hex0(uid.data4(0), 2) & _
hex0(uid.data4(1), 2) & "-"
For i = 2 To 7
NewGUID = NewGUID & hex0(uid.data4(i), 2)
Next
If braces Then
NewGUID = "{" & NewGUID & "}"
End If
End Function
Private Function hex0(N, digits As Integer) As String
hex0 = Hex(N)
hex0 = String(digits - Len(hex0), "0") & hex0
End Function
Function XDATA_Set(appName As String, entXd As Object, xdStr As String) As Boolean
XDATA_Set = False
Dim xdataType(0 To 1) As Integer
Dim xdata(0 To 1) As Variant
On Error Resume Next: ERR.Clear: xdataType(0) = 1001: xdataType(1) = 1000: xdata(0) = appName: xdata(1) = xdStr: entXd.SetXData xdataType, xdata: On Error GoTo 0
If ERR.Number = 0 Then XDATA_Set = True
End Function
Function XDATA_Del(appName As String, entXd As Object) As Boolean
XDATA_Del = False
Dim xdataType(0 To 0) As Integer
Dim xdata(0 To 0) As Variant
On Error Resume Next: ERR.Clear: xdataType(0) = 1001: xdata(0) = appName: entXd.SetXData xdataType, xdata: On Error GoTo 0
If ERR.Number = 0 Then XDATA_Del = True
End Function
Function XDATA_Get(appName As String, entity As Object, S As String) As Boolean
XDATA_Get = False
Dim xdataType As Variant
Dim xdata As Variant
On Error Resume Next
ERR.Clear
entity.GetXData appName, xdataType, xdata
S = xdata(1)
On Error GoTo 0
If ERR.Number = 0 Then XDATA_Get = True
End Function
Function Entity_Set_EXT(entity As Object, TAG As String, value As String) As Boolean
Entity_Set_EXT = False
Dim dict As AcadDictionary
Dim RECORD As AcadXRecord
Const TYPE_STRING = 1
On Error Resume Next
Set dict = entity.GetExtensionDictionary
ERR.Clear
Set RECORD = dict.GetObject(TAG)
If ERR.Number <> 0 Then
Set RECORD = dict.AddXRecord(TAG)
End If
On Error GoTo ulos
RECORD.TranslateIDs = True
ERR.Clear
ArraySize = 0
Dim XRecordDataType As Variant
Dim XRecordData As Variant
ReDim XRecordDataType(0 To ArraySize) As Integer
ReDim XRecordData(0 To ArraySize) As Variant
XRecordDataType(0) = 1000
XRecordData(0) = value
Call RECORD.SetXRecordData(XRecordDataType, XRecordData)
'RECORD.GetXRecordData XRecordDataType, XRecordData
If ERR.Number = 0 Then Entity_Set_EXT = True
ulos:
End Function
Function Entity_Get_EXT(entity As Object, TAG As String, value As String) As Boolean
Entity_Get_EXT = False
Dim dict As AcadDictionary
Dim RECORD As AcadXRecord
ArraySize = 0
Dim XRecordDataType As Variant
Dim XRecordData As Variant
On Error GoTo ulos
If entity.HASEXTENSIONDICTIONARY Then
ERR.Clear
On Error Resume Next
Set dict = entity.GetExtensionDictionary
Set RECORD = dict.GetObject(TAG)
RECORD.GetXRecordData XRecordDataType, XRecordData
value = XRecordData(0)
On Error GoTo 0
If ERR.Number = 0 Then Entity_Get_EXT = True
End If
ulos:
End Function
Public Function DWG_SET_XENTRY(DNAME As String, DTAG As String, ID, ENTRY) As Boolean
DWG_SET_XENTRY = False
Dim oDict As AcadDictionary
Dim oXRec As AcadXRecord
Dim N As Long
Dim dxfCode() As Integer
Dim dxfdata()
N = 0
On Error Resume Next
ERR.Clear
Set oDict = thisdrawing.Dictionaries.ITEM(DNAME)
If ERR.Number <> 0 Then
ERR.Clear
Set oDict = thisdrawing.Dictionaries.Add(DNAME)
ERR.Clear
Set oDict = thisdrawing.Dictionaries.ITEM(DNAME)
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
End If
ERR.Clear
Set oXRec = oDict.ITEM(DTAG)
If ERR.Number <> 0 Then
ERR.Clear
Set oXRec = oDict.AddXRecord(DTAG)
Debug.Print ERR.DESCRIPTION
ERR.Clear
Set oXRec = oDict.ITEM(DTAG)
If ERR.Number <> 0 Then
Exit Function
End If
End If
On Error GoTo 0 'Resume Next
ERR.Clear
oXRec.GetXRecordData dxfCode, dxfdata
On Error Resume Next
Debug.Print dxfdata(0)
N = UBound(dxfdat)
If ID >= N Then
ReDim Preserve dxfCode(ID)
ReDim Preserve dxfdata(ID)
For i = N To ID
dxfCode(ID) = 1
Next
End If
ERR.Clear
dxfCode(ID) = 1
dxfdata(ID) = ENTRY
oXRec.SetXRecordData dxfCode(), dxfdata()
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
DWG_SET_XENTRY = True
End Function
Public Function DWG_SET_XENTRY_ALL(DNAME As String, DTAG As String, DATA) As Boolean
DWG_SET_XENTRY_ALL = False
Dim oDict As AcadDictionary
Dim oXRec As AcadXRecord
Dim N As Long
Dim dxfCode() As Integer
Dim dxfdata()
N = 0
On Error Resume Next
ERR.Clear
Set oDict = thisdrawing.Dictionaries.ITEM(DNAME)
If ERR.Number <> 0 Then
ERR.Clear
Set oDict = thisdrawing.Dictionaries.Add(DNAME)
ERR.Clear
Set oDict = thisdrawing.Dictionaries.ITEM(DNAME)
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
End If
ERR.Clear
Set oXRec = oDict.ITEM(DTAG)
If ERR.Number <> 0 Then
ERR.Clear
Set oXRec = oDict.AddXRecord(DTAG)
Debug.Print ERR.DESCRIPTION
ERR.Clear
Set oXRec = oDict.ITEM(DTAG)
If ERR.Number <> 0 Then
Exit Function
End If
End If
On Error GoTo 0 'Resume Next
ERR.Clear
N = UBound(DATA)
ReDim dxfCode(ID)
ReDim dxfdata(ID)
For i = N To ID
dxfCode(i) = 1
dxfdata(i) = DATA(i)
Next
ERR.Clear
oXRec.SetXRecordData dxfCode(), dxfdata()
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
DWG_SET_XENTRY_ALL = True
End Function
Public Function DWG_GET_XENTRY(DNAME As String, DTAG As String, ID, DATA) As Boolean
DWG_GET_XENTRY = False
Dim oDict As AcadDictionary
Dim oXRec As AcadXRecord
Dim N As Long
N = 0
ReDim IDX(N)
ReDim DATA(N)
ERR.Clear
On Error Resume Next
Set oDict = thisdrawing.Dictionaries.ITEM(DNAME)
Set oXRec = oDict.ITEM(DTAG)
ReDim IDX(0)
IDX(0) = ID
oXRec.GetXRecordData IDX, DATA
DATA = DATA(ID)
DWG_GET_XENTRY = ERR.Number = 0
End Function
Public Function DWG_GET_XENTRY_ALL(DNAME As String, DTAG As String, DATA, Optional N As Long) As Boolean
DWG_GET_XENTRY_ALL = False
Dim oDict As AcadDictionary
Dim oXRec As AcadXRecord
N = 0
ReDim IDX(N)
ReDim DATA(N)
ERR.Clear
On Error Resume Next
Set oDict = thisdrawing.Dictionaries.ITEM(DNAME)
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
Set oXRec = oDict.ITEM(DTAG)
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
oXRec.GetXRecordData IDX, DATA
If ERR.Number <> 0 Then
Debug.Print ERR.DESCRIPTION
Exit Function
End If
N = UBound(DATA)
DWG_GET_XENTRY_ALL = ERR.Number = 0
End Function
Sub testxentry()
DATA = "HALLO"
Call DWG_SET_XENTRY("TEST", "WILLI", 0, DATA)
DATA = ""
Call DWG_GET_XENTRY("TEST", "WILLI", 0, DATA)
Debug.Print DATA
Debug.Print DWG_GET_XENTRY_ALL("TEST", "WALLY", DATA)
ERR.Clear
Debug.Print DWG_GET_XENTRY_ALL("TEST", "WILLI", DATA)
Debug.Print N
End Sub
Function Select_entity_by_xdata(sset As AcadSelectionSet, appName As String) As AcadSelectionSet '(sset As AcadSelectionSet, blockName As String)
Dim FilterType As Variant
Dim FilterData As Variant
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim grpCode(0) As Integer
Dim grpValue(0) As Variant
grpCode(0) = 1001
grpValue(0) = appName
FilterData = grpValue
FilterType = grpCode
On Error Resume Next
sset.Select acSelectionSetAll, , , FilterType, FilterData
End Function
------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP