| |
| Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
Autor
|
Thema: Schrittweise Auswertung der Zeichnung mit SelectAtPoint (1970 mal gelesen)
|
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 08:23 <-- editieren / zitieren --> Unities abgeben:
Hallo Forum, neues Problem, alte Baustelle! Habe ne Fläche mit kleinen Schraffurflächen Excel 2003 in ACAD 2004 erstellt. In diesem Bereich füllen die Einzelflächen (Solid, schwarz dargestellt) nicht den gesamten Bereich aus. Nun möchte ich die Restfläche (weiß )in einem bestimmten Rahmen ermitteln. Laufe hierfür in Rasterschritten über den Bereich und ermittle die Eigenschaften jedes Rasterpunktes. Ist der Typenname eine Schraffur („AcDbHatch“ ) soll er zum nächsten Rasterpunkt gehen, findet er etwas anderes soll der Befehl Umgrenzung durchgeführt, die Fläche des Polygons ermittelt und aufsummiert werden. Beim Starten des Makros wird angezeigt „Loop ohne Do“. Wäre nett wenn ihr mal drüber schaut…: Dim xWert As Double Dim rasterschritt As Double Dim streckeX As Double Dim point(0 To 2) As Double Dim yWert As Double Dim streckeY As Double xWert = 0 'X Wert des momnetan betrachteten Punktes yWert = 0 'Y Wert des momnetan betrachteten Punktes rasterschritt = 0.05 streckeX = 50 'Bildbreite streckeY = 50 'Bildhöhe 'Erstellen desAuswahlsatzes Dim ssetObj As AcadSelectionSet 'Set ssetObj = AcadApp.ActiveDocument.SelectionSets.Add("SOLID") 'Daten der Umgrenzung Dim plineObj As AcadPolyline Dim plineArea As Double Dim XTypeOut As Variant Dim XDataOut As Variant Dim XYPoint As String Do While yWert > streckeY yWert = yWert + rasterschritt Do While xWert > streckeX xWert = xWert + rasterschritt point(0) = xWert: point(1) = yWert: point(2) = 0# XYPoint = CStr(point(0)) & "," & CStr(point(1)) 'Erzeugung eines String aus Koordinaten für Umgrenzung ssetObj.SelectAtPoint (point) Select Case TypeName(ssetObj) Case "AcDbHatch" Case Else With AcadApp.ActiveDocument Set plineObj = .SendCommand("._-boundary" & vbCr & "A" & vbCr & "_Island" & vbCr & "N" & vbCr & "N" & vbCr & "O" & vbCr & "_Polyline" & vbCr & vbCr & XYPoint & vbCr & vbCr) End With plineArea = plineArea + plineObj.Area Loop Loop Und mir mögliche andere Fehler / Gedankenfehler zeigt. Ich bin mir nicht sicher was hiervon richtig ist und was nicht. Vielen Dank SAGU
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Carsten1210 Mitglied staatl. geprüfter Holztechniker
Beiträge: 1357 Registriert: 24.07.2002 AutoCAD ACA 2018 Solidworks 2016 Sp5 Enterprise PDM 2016 Sp5 Pascam Woodworks Visual Studio 2017 Pro Windows 10 64Bit Dell T3620 Intel Core i7-7700K 16 GB Arbeitsspeicher 2x Samsung S24C650 Dell M4800
|
erstellt am: 15. Mrz. 2007 08:49 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
|
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 10:44 <-- editieren / zitieren --> Unities abgeben:
Danke Carsten für den Tip. Ich hab über den Befehl SendCommand die Polylinie erstellt. Wie kann ich auf diese Linie zugreifen. Ich benötige hiervon den Flächeninhalt. Das was ich schrieb funktioniert nicht. Wie wird die Polylinie zugewiesen? Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 10:46 <-- editieren / zitieren --> Unities abgeben:
|
Carsten1210 Mitglied staatl. geprüfter Holztechniker
Beiträge: 1357 Registriert: 24.07.2002 AutoCAD ACA 2018 Solidworks 2016 Sp5 Enterprise PDM 2016 Sp5 Pascam Woodworks Visual Studio 2017 Pro Windows 10 64Bit Dell T3620 Intel Core i7-7700K 16 GB Arbeitsspeicher 2x Samsung S24C650 Dell M4800
|
erstellt am: 15. Mrz. 2007 10:50 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
Hi, Da die Polylinie das letzte erstellte Element ist, würde ich über "acSelectionSetLast" auf dieses Element zugreifen. Mit selectbypolygon kannst du eine Auswahl mit einem nicht rechteckigen Fenster (über Koordinaten) bestimmen, analog zum auswählen in Autocad über Fensterpolygon und Kreuzenpolygon. Gruß, Carsten [Diese Nachricht wurde von Carsten1210 am 15. Mrz. 2007 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 13:12 <-- editieren / zitieren --> Unities abgeben:
Zum Punkt acSelectionSetLast bin ich noch nicht vorgedrungen... Beim Ausführen des Makros kommt mal die Fehlermeldung „436 Objekt unterstützt diese Eigenschaft oder Mehtode nicht“ oder „91 With-Blockvariable nicht festgelegt“. Es werden die Zeilen mit * passend zu den Melfdungen gelb markiert. Was mache ich flasch? Hab wieder auf den Seiten und in der ACAD Hilfe herumgestöbert. Bin aber nicht weiter gekommen. Kann ich die Schraffur der Polylinie so anhängen? Hab es bei einem Kreis ähnlich gemacht. … Dim plineObj As AcadPolyline Dim xWert As Double Dim rasterschritt As Double Dim streckeX As Double Dim point(0 To 2) As Double Dim yWert As Double Dim streckeY As Double Dim plineArea As Double 'Erstellen desAuswahlsatzes * Dim ssetObj As AcadSelectionSet Dim Umgrenzung(0) As AcadPolyline xWert = 3 'X Wert des momnetan betrachteten Punktes yWert = -3 'Y Wert des momnetan betrachteten Punktes rasterschritt = 0.05 streckeX = 40 'Bildbreite streckeY = -20 'Bildhöhe plineArea = 0 'Dim ssetObj As AcadSelectionSet * Set ssetObj = AcadApp.ActiveDocument.SelectionSet.Add("Umgrenzung") Do While yWert > streckeY Do While xWert < streckeX point(0) = xWert: point(1) = yWert: point(2) = 0# XYPoint = CStr(point(0)) & "," & CStr(point(1)) 'Erzeugung eines String aus Koordinaten für Umgrenzung ssetObj.SelectAtPoint (point) Select Case TypeName(ssetObj) Case "AcDbHatch" Case Else With AcadApp.ActiveDocument .SendCommand ("._-boundary" & vbCr & "A" & vbCr & "_Island" & vbCr & "N" & vbCr & "N" & vbCr & "O" & vbCr & "_Polyline" & vbCr & vbCr & XYPoint & vbCr & vbCr) End With plineObj.Select (acSelectionSetLast) plineArea = plineArea + plineObj.Area With AcadApp.ActiveDocument Set hatchObjUmgrenzung = .ModelSpace.AddHatch(PatternType, patternName, bAssociativity) Set Umgrenzung(0) = .ModelSpace.plineObj End With hatchObjUmgrenzung.AppendOuterLoop (plineObj) 'Anhängen der Schraffur an den Kreis hatchObj.Evaluate End Select xWert = xWert + rasterschritt Loop yWert = yWert - rasterschritt Loop MsgBox "Fehlfläche ist " & plineArea Range("AH2").Value = plineArea Hier scheinen wohl noch einige Fehler versteckt! Danke für die Hilfe Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
startrek Moderator Architekt
Beiträge: 1361 Registriert: 13.02.2003 .
|
erstellt am: 15. Mrz. 2007 13:25 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
|
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 13:29 <-- editieren / zitieren --> Unities abgeben:
|
Stelli1 Moderator Verm.-Ing.
Beiträge: 1521 Registriert: 17.08.2005 Map 2000-2014, Rasterdesign, MapGuide, Autodesk Topobase, VS6, VS.net 2013
|
erstellt am: 15. Mrz. 2007 13:48 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
Hallo, es gibt da wohl noch ein paar Punkte ... Ein selectionset (mit und ohne s) mit gleichen Namen kann nur einmal pro Zeichnung existieren. Du musst prüfen ob eines da ist und wenn nicht eins anlegen.
Code:
on error resume next set sset = thisdrawing.selectionsets("Mysel") if err.number then set sset = thisdrawing.selectionsets.add("Mysel") end if on error goto 0
Wenn du per Sendcommand ein Element erzeugts kannst du dir dieses in der passenden Ereignisroutine in AutoCAD abfangen.
Code:
'' Thisdrawing Code Private Sub AcadDocument_ObjectAdded(ByVal Object As Object) Set NeuesElement = Object End Sub'' Code aus Modul Public NeuesElement As Object Sub test() ThisDrawing.SendCommand ("_-boundary 130,50" & vbCrLf) If Not NeuesElement Is Nothing Then NeuesElement.color = 1 End If End Sub
Aber da war mal die Rede von Gedankenfehler. Vielleicht erzählst du mal was du überhaupt bewirken willst. Meines Erachtens gibt es doch falsche Ergebnisse wenn du für jeden Punkt eine Umgrenzunng erstellst. Wenn innerhalb einer offenen Fläche mehrere Rasterpunkte liegen würdest du die Umgenzung mehrmals erstellen. Ob ein Punkt innerhalb oder ausserhalb eines oder mehrerer Kreise liegt kannst du doch auch in Excel durch Streckenberechnung ermitteln. Stelli ------------------ Warum lisp'eln wenn's auch anders geht. www.ib-stelberg.de Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 15:14 <-- editieren / zitieren --> Unities abgeben:
Ich dachte, ich hätte es beschrieben. Mein Fehler. Das Makro dient zum Erstellen eines Modells mit abweichenden Parametern. Diese verursachen in der überwiegen mit "Solid" gefüllten Fläche einige nicht gefüllte Bereiche. Sie werden jeweils von n Kreisausschnitten begrenzt. Mein Algorithmus sollte über ein Raster die gesamte Fläche scannen und feststellen ob es an dem gerade zu betrachtenden Punkt eine gefüllte Fläche gibt. Ist das der Fall springt er zum nächsten Punkt. Ist es nicht der Fall, soll er von der nicht gefüllten Fläche den Flächeninhalt ermitteln (durch Umgrenzung und Flächeninhalt der dazugehörigen Polygonlinie oder so ähnlich), alle nicht gefüllten Flächen in einer Variablen aufsummieren und am Ende diese gesamte Fläche als Double an Excel zurück geben. Um beim nächsten Rasterpunkt nicht die selbe Fläche doppelt oder mehrfach zu addieren, muss die Fläche nach Ermittlung des Flächeninhaltes ebenfalls mit "Solid" gefüllt werden. Soweit die Theorie…
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 15:37 <-- editieren / zitieren --> Unities abgeben:
Soweit die Theorie… Ach so zu den Berechnungen, mein erster Schritt war ein Berechnungsalgorithmus in Excel. Der funktioniert auch ganz gut. Bis auf eine bestimmte Prozentzahl lassen sich die fehlenden Flächen ermitteln. Bei Veränderung der Eingangsparameter lässt sich der Fehler durch die unbetrachteten Kreise nicht abschätzen. Hier fand ich als beste Alternative: die Verbindung zwischen ACAD und Excel. Der Nachteil in Excel lassen sich nur eine bestimmte Anzahl an benachbarten Kreisen gleichzeitig analysieren (in meinem Fall 3). Die Verbindung beider Programme schafft eine 100% Lösung. In Excel werden die Kreise normalverteilt erzeugt und über ACAD die fehlende Fläche ermittelt. Das macht Acad auch zuverlässig, wenn an einer nicht gefüllten Fläche mehr als drei Kreise beteiligt sind. Excel nur bedingt. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 15. Mrz. 2007 19:37 <-- editieren / zitieren --> Unities abgeben:
Hallo Stelli1, habe deinen Hinweis wie folgt übernommen: Public NeuesElement As AcadObject Private Sub AcadDocument_ObjectAdded(ByVal Object As AcadObject) Set NeuesElement = Object End Sub AcadApp.ActiveDocument.SendCommand ("._-boundary" & vbCr & "A" & vbCr & "_Island" & vbCr & "N" & vbCr & "N" & vbCr & "O" & vbCr & "_Polyline" & vbCr & vbCr & XYPoint & vbCr & vbCr) If Not NeuesElement Is Nothing Then plineArea = NeuesElement.Area End If Es kommt eine Fehlermeldung, Typen unverträglich. Was mache ich falsch? Ich stellte fest, dass der TypeName von meiner Select Case Anweisung nicht der richtige ist. Wie kann ich diesen ermitteln? Danke für die Hilfe
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Stelli1 Moderator Verm.-Ing.
Beiträge: 1521 Registriert: 17.08.2005 Map 2000-2014, Rasterdesign, MapGuide, Autodesk Topobase, VS6, VS.net 2013
|
erstellt am: 15. Mrz. 2007 20:03 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
Hallo, das eine hat mit dem anderen nichts zu tun. Zitat: Original erstellt von Sagu: Public NeuesElement As AcadObject ... Es kommt eine Fehlermeldung, Typen unverträglich. Was mache ich falsch?
sollte auch Public NeuesElement As Object heissen. Um den Typnamen oder anderes festzustellen klicks du auf den Objektnamen im Code (während der Laufzeit mit Breakpoint) und drückst shift+F9. Dann kannst du die Eigenschaften des Objektes im Überwachungsfenster anschauen. Stelli Stelli
------------------ Warum lisp'eln wenn's auch anders geht. www.ib-stelberg.de Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 16. Mrz. 2007 10:13 <-- editieren / zitieren --> Unities abgeben:
Guten Morgen Stelli1, die Tips die Du mir gegeben hast laufen in AutoCAD super. Das Problem entsteht, wenn ich die Sachen in mein Excel Makro übernehme. Mein Code sieht wie folgt aus: Sub X() Dim i As Integer Dim kx As Double Dim ky As Double Dim r As Double Dim ThisDrawing As AcadDocument Dim centerPoint(0 To 2) As Double Dim radius As Double Dim hatchObj As AcadHatch Dim kreis(0 To 0) As AcadEntity Dim patternName As String Dim PatternType As Long Dim bAssociativity As Boolean 'Daten der Umgrenzung patternName = "Solid" PatternType = 0 bAssociativity = True Set AcadApp = CreateObject("autocad.application") AcadApp.Visible = -1 For i = 8 To 1008 kx = Range("AG" & i) 'X-Koordinate vom Kreismittelpunkt ky = Range("AH" & i) 'Y-Koordinate vom Kreismittelpunkt r = Range("AI" & i) 'Radius vom Kreis centerPoint(0) = kx: centerPoint(1) = ky: centerPoint(2) = 0# radius = r With AcadApp.ActiveDocument 'Erstellen einer Schraffur und zuweisen Set hatchObj = .ModelSpace.AddHatch(PatternType, patternName, bAssociativity) Set kreis(0) = .ModelSpace.AddCircle(centerPoint, radius) 'Erzeugung eines Kreises und Zuweisung hatchObj.AppendOuterLoop (kreis) 'Anhängen der Schraffur an den Kreis hatchObj.Evaluate End With Next i AcadApp.ActiveDocument.Regen True AcadApp.ZoomExtents Dim plineObj As AcadPolyline Dim xWert As Double Dim rasterschritt As Double Dim streckeX As Double Dim point(0 To 2) As Double Dim yWert As Double Dim streckeY As Double Dim NeuesElement As Double 'Erstellen desAuswahlsatzes Dim ssetObj As AcadSelectionSet Dim Umgrenzung(0) As AcadPolyline Dim PolylinePoints(0 To 14) As Double xWert = 3 'X Wert des momnetan betrachteten Punktes yWert = -3 'Y Wert des momnetan betrachteten Punktes rasterschritt = 0.05 streckeX = 40 'Bildbreite streckeY = -20 'Bildhöhe plineArea = 0 PolylinePoints(0) = xWert: PolylinePoints(1) = yWert: PolylinePoints(2) = 0# PolylinePoints(3) = streckeX: PolylinePoints(4) = yWert: PolylinePoints(5) = 0# PolylinePoints(6) = streckeX: PolylinePoints(7) = streckeY: PolylinePoints(8) = 0# PolylinePoints(9) = xWert: PolylinePoints(10) = streckeY: PolylinePoints(11) = 0# PolylinePoints(12) = xWert: PolylinePoints(13) = yWert: PolylinePoints(14) = 0# With AcadApp.ActiveDocument 'Erstellen eines Rechtecks .ModelSpace.AddPolyline (PolylinePoints) End With On Error Resume Next Set ssetObj = AcadApp.ActiveDocument.SelectionSets("Umgrenzung") If Err.Number Then Set ssetObj = AcadApp.ActiveDocument.SelectionSets.Add("Umgrenzung") End If On Error GoTo 0 Do While yWert > streckeY Do While xWert < streckeX point(0) = xWert: point(1) = yWert: point(2) = 0# XYPoint = CStr(point(0)) & "," & CStr(point(1)) 'Erzeugung eines String aus Koordinaten für Umgrenzung ssetObj.SelectAtPoint (point) Select Case TypeName(ssetObj) Case "AcadacHatch" Case Else 'MsgBox "Punkt" & "X: " & xWert & "Y: " & yWert 'With AcadApp.ActiveDocument AcadApp.ActiveDocument.SendCommand ("._-boundary" & vbCr & "A" & vbCr & "_Island" & vbCr & "N" & vbCr & "N" & vbCr & "O" & vbCr & "_Polyline" & vbCr & vbCr & XYPoint & vbCr & vbCr) If Not NeuesElement Is Nothing Then plineArea = NeuesElement.Area End If 'End With 'plineObj.Select (acSelectionSetLast) 'plineArea = plineArea + NeuesElement.Area With AcadApp.ActiveDocument Set hatchObjUmgrenzung = .ModelSpace.AddHatch(PatternType, patternName, bAssociativity) Set Umgrenzung(0) = .ModelSpace.plineObj End With hatchObjUmgrenzung.AppendOuterLoop (plineObj) 'Anhängen der Schraffur an den Kreis hatchObj.Evaluate End Select xWert = xWert + rasterschritt Loop yWert = yWert - rasterschritt Loop MsgBox "Fehlfläche ist " & plineArea Range("AH2").Value = plineArea End Sub In der Routine "On Error Resume Next" hängt er sich beim ausführen auf. Ich erhalte trotzdem eine Fehlermeldung: konnte Schlüssel nicht finden. Bei der Zeile " If Not NeuesElement Is Nothing Then" wird der Fehler "Typen unverträglich " angezeigt. Hier habe ich es mit mehreren Varianten für die Deklaration "NeuesElement", ähnlich der im Beitrag darüber probiert, immer mit dem selben Ergebnis . Und da wäre noch eine Kleinigkeit... Über das Lokalfenster bekomme ich die Werte und Typen der Variablen(?). Nun findet sich kein TypeName der Schraffur dort. Über Deine Hilfe Shift F9 bekomme ich auch keine weiteren Infos. Hier wird stets nichts Brauchbares angezeigt, auch nicht mit einem Haltepunkt. Hilfe, Hilfe, Hilfe das sollte doch nur ein kleines Makro werden. Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
startrek Moderator Architekt
Beiträge: 1361 Registriert: 13.02.2003 .
|
erstellt am: 16. Mrz. 2007 10:32 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
Hi Sagu, late vs. early Binding: http://ww3.cad.de/foren/ubb/Forum259/HTML/000741.shtml#000001 mit createObject(application) greiftst du immer via late binding zu, d.h. es gibt kein Code:
dim zeichnung as acadDocument ' sondern immer nur dim zeichnung as Object
Ebenso die Acad-Konstanten wie PatternType, patternName, bAssociativity musst Du dir neu/selbst definieren indem du mal unter <F2> im Objektkatalog guckst und dir die zugehörigen Long-Werte der Konstanten her nimmst.Oder aber du setzt 'nen Verweis auf die Acad-Library;-) lg Nancy (die bissel kurz angebunden ist) Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Stelli1 Moderator Verm.-Ing.
Beiträge: 1521 Registriert: 17.08.2005 Map 2000-2014, Rasterdesign, MapGuide, Autodesk Topobase, VS6, VS.net 2013
|
erstellt am: 16. Mrz. 2007 11:09 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
Hallo, das Problem bei dir ist folgendes. In AutoCAD wird der Event AcadDocument_ObjectAdded ausgelöst und abgearbeitet. In Excel natürlich nicht, es sein denn du hast den Datentyp mit der Option withevents deklariert. Ungetestet müsste das so aussehen:
Code:
Dim withevents AcadDoc as acadDocument'Ergeignisroutine sub AcadDoc_ObjectAdded (ByVal Object As Object) ' Code end sub
In einem gewissen Punkt wiederspreche ich da Nancy. Mit Create/GetObject kann man auch early Binding einsetzen. Ich bevorzuge das weil man dann sauber mit den Datentypen arbeiten kann.Wenn man das in Excel nicht mit dem Event hinbekommt kann man da auch einen kleinen Workaround machen. Bevor du mit Sendcommand den Befehl _boundary loslässt speicherst du in einer Variablen die Anzahl der Entitys (thisdrawing.modespace.count)
Code: Dim NeuesElement As AcadEntity Dim AnzahlEntity As LongAnzahlEntity = ThisDrawing.ModelSpace.Count ThisDrawing.SendCommand "_circle 4,4 50 " If ThisDrawing.ModelSpace.Count > AnzahlEntiy Then ' Letztes Element abgreifen Set NeuesElement = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1) NeuesElement.color = 1 NeuesElement.Update End If
Das sollte auch in Excel klappen. Übrings sollest du zum Testen immer mal die On Error Resume Next auskommentieren. Dann bekommst du eine reale Fehlermeldung Stelli ------------------ Warum lisp'eln wenn's auch anders geht. www.ib-stelberg.de Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Stelli1 Moderator Verm.-Ing.
Beiträge: 1521 Registriert: 17.08.2005 Map 2000-2014, Rasterdesign, MapGuide, Autodesk Topobase, VS6, VS.net 2013
|
erstellt am: 16. Mrz. 2007 11:19 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
Übringens noch ein kleiner Tipp. Versuch doch mal dein Posting ein wenig aufzuräumen. Da kann man sonst schwer Code vom Text unterscheiden. Und ein wenig Einrückungen im Quelltext würde die Übersichtlichkeit sehr fördern. Stelli ------------------ Warum lisp'eln wenn's auch anders geht. www.ib-stelberg.de Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 17. Mrz. 2007 11:23 <-- editieren / zitieren --> Unities abgeben:
Hallo Stelli1, innerhalb der letzten 70h Arbeit waren nicht viele Erfolgsmeldungen zu verbuchen. Nun ist es wieder so weit. Bin dazu übergegangen kleine Programme zu schreiben, um mich auf den entsprechenden Fehler zu konzetrieren. Hätte ich vielleicht schon früher machen sollen. Über den ersten Teil habe ich es nicht hin bekommen, der Workaround klappt. Hier der Code: Sub Beispiel() Dim NeuesElement As AcadEntity Dim AnzahlEntity As Long Dim AcadApp As AcadApplication Set AcadApp = CreateObject("autocad.application") AcadApp.Visible = -1AnzahlEntity = AcadApp.ActiveDocument.ModelSpace.Count AcadApp.ActiveDocument.SendCommand "_circle 4,4 50 " If AcadApp.ActiveDocument.ModelSpace.Count > AnzahlEntity Then Set NeuesElement = AcadApp.ActiveDocument.ModelSpace(AcadApp.ActiveDocument.ModelSpace.Count - 1) NeuesElement.Color = 1 NeuesElement.Update AcadApp.ZoomExtents End If End Sub
Werde weiter herumprobieren. Es sollten nicht mehr viele Fragen werden. Einige hab ich noch ... ganz bestimmt. Bin wohl kein einfacher Patient. Ich bedanke mich schon mal für die intensive Betreuung.Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 17. Mrz. 2007 13:46 <-- editieren / zitieren --> Unities abgeben:
Hallo Forum, zum Überprüfen ob ein SelectioSet vorhanden ist, hab ich die Routinen Code: On Error Resume Next Set objSelSet = AcadApp.ActiveDocument.SelectionSets("Selection") If Err.Number Then Set sset = AcadApp.ActiveDocument.SelectionSets.Add("Selection") End If On Error GoTo 0
oderCode: If Err.Number = 0 Then objSelSet.Clear Err.Clear Else Set objSelSet = AcadApp.ActiveDocument.Add("Selection") On Error GoTo 0 End If
eingesetzt. Mit keinem Erfolg. Die Fehlermeldung "Schlüssel nicht gefunden" taucht auf. Genau das oder besser die Fehelermeldung, dass das SelectionSet schon vorhanden ist, sollte doch verhindert werden. Deaktiviere ich die Routine kommt im zweiten Durchlauf der Schleife genau das (SelectionSet vorhanden). Was läuft falsch? In der Select Case Anweisung Code: Select Case TypeName(objSelSet) Case "AcadHatch" Case Else ... End Select
sollte er aus der Select Anweisung herausgehen, wenn er den TypeName vom Objekt mit "AcdHatch" verglichen hat. Ist dieser für eine Schraffur "AcdHatch" oder "IAcdHatch"?Danke Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Carsten1210 Mitglied staatl. geprüfter Holztechniker
Beiträge: 1357 Registriert: 24.07.2002 AutoCAD ACA 2018 Solidworks 2016 Sp5 Enterprise PDM 2016 Sp5 Pascam Woodworks Visual Studio 2017 Pro Windows 10 64Bit Dell T3620 Intel Core i7-7700K 16 GB Arbeitsspeicher 2x Samsung S24C650 Dell M4800
|
erstellt am: 17. Mrz. 2007 14:08 <-- editieren / zitieren --> Unities abgeben: Nur für Sagu
|
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 18. Mrz. 2007 09:04 <-- editieren / zitieren --> Unities abgeben:
Hallo Forum, zur Zeit versuche ich mich an meinem SelectionSet. Ich bin davon ausgegangen, dass, wenn ich über SelectAtPoint einen Punkt, der auf einer Schraffur liegt, dem SelectionSet der TypeName der Schraffur zugeordnet wird. Über eine MsgBox kommt "Punkt" als Ausgabe. Mein Problem ist, dass ich für die Select Case Anweisung eine Eigenschaft der Schraffur benötige (siehe Code oben). Über Filter hab ich es nicht hinbekommen und auch schon im Forum geblättert. Wie kann ich eine Eigenschaft, die bei allen Schraffuren gleich ist (wie Solid, Hatch usw.) des SelectionSets in die Select Case Anweisung einbinden. Er soll, an jedem Punkt an dem er DIE Eigenschaft der Schraffur findet, aus der Anweisung rausgehen. Der TypeName fällt wohl aus... Danke Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
| Technischer Projektleiter (m/w/d) Bereich Glasarchitektur | Jeden Tag meistern Sie neue Herausforderungen und lieben es, selbstständig zu arbeiten. Sie möchten echten Erfolg mitgestalten. Haben Sie auch einen Arbeitgeber, der das zu schätzen weiß? Rund 1300 Mitarbeitende bei LAMILUX schon! Deswegen sind wir eines der wachstumsstärksten Familienunternehmen Oberfrankens und weltweit führend in unseren Märkten: Wir produzieren faserverstärkte Kunststoffe für den weltweiten Bau von Nutzfahrzeugen, Caravans oder auch Bussen.... | Anzeige ansehen | Projektmanagement |
|
Sagu Mitglied Dipl - Ing
Beiträge: 31 Registriert: 11.03.2007
|
erstellt am: 19. Mrz. 2007 09:28 <-- editieren / zitieren --> Unities abgeben:
Hallo Wissende, hab am WE mein Code vervollständigt, um danach festzustellen, dass mit der SelectAtPoint Methode im Acad Modellbereich, in dem keine Objekte an diesem Punkt gefunden werden, Objekte der näheren Umgebung herangezogen werden. Genau das sollte nicht passieren! Code: Dim xWert As Double Dim yWert As Double Dim streckeX As Double Dim streckeY As Double Dim rasterschritt As Double Dim lineObj As AcadLine Dim olLinePoint(0 To 2) As Double Dim orLinePoint(0 To 2) As Double Dim urLinePoint(0 To 2) As Double Dim ulLinePoint(0 To 2) As Double Dim point(0 To 2) As Double Dim SelObj As AcadObject Dim objSelSet As AcadSelectionSet Dim plineObj As AcadPolyline Dim hatchObjUmgrenzung As AcadHatch Dim NeuesElement As AcadEntity Dim Umgrenzung(0 To 0) As AcadEntity 'AcadPolyline Dim AnzahlEntity As Long Dim plineArea As Double xWert = 3 'X Wert des momnetan betrachteten Punktes yWert = -3 'Y Wert des momnetan betrachteten Punktes rasterschritt = 0.05 streckeX = 40 'Bildbreite streckeY = -10 'Bildhöhe plineArea = 0 'olLinePoint(0) = xWert: olLinePoint(1) = yWert: olLinePoint(2) = 0# 'orLinePoint(0) = streckeX: orLinePoint(1) = yWert: orLinePoint(2) = 0# 'urLinePoint(0) = streckeX: urLinePoint(1) = streckeY: urLinePoint(2) = 0# 'ulLinePoint(0) = xWert: ulLinePoint(1) = streckeY: ulLinePoint(2) = 0# 'With AcadApp.ActiveDocument 'Erstellen eines Rechtecks 'Set lineObj = AcadApp.ActiveDocument.ModelSpace.AddLine(olLinePoint, orLinePoint) 'Set lineObj = AcadApp.ActiveDocument.ModelSpace.AddLine(orLinePoint, urLinePoint) 'Set lineObj = AcadApp.ActiveDocument.ModelSpace.AddLine(urLinePoint, ulLinePoint) 'Set lineObj = AcadApp.ActiveDocument.ModelSpace.AddLine(ulLinePoint, olLinePoint) 'AcadApp.ActiveDocument.Regen True 'AcadApp.ZoomExtents 'End With 'On Error Resume Next 'Set objSelSet = AcadApp.ActiveDocument.SelectionSets("Selection") 'If Err.Number Then 'Set objSelSet = AcadApp.ActiveDocument.SelectionSets.Add("Selection") 'End If 'On Error GoTo 0 'yWert = yWert - 2.3 yWert = -6.06 xWert = 21.1 Do While yWert > streckeY yWert = yWert - rasterschritt Do While xWert < streckeX xWert = xWert + rasterschritt Set objSelSet = AcadApp.ActiveDocument.SelectionSets.Add("Selection") point(0) = xWert: point(1) = yWert: point(2) = 0# XYstring = Trim(Str(point(0))) & "," & Trim(Str(point(1))) 'Erzeugung eines String aus Koordinaten für Umgrenzung objSelSet.SelectAtPoint (point) On Error Resume Next Set SelObj = objSelSet.Item(0) On Error GoTo 0 'MsgBox "Name " & SelObj.ObjectName & " " & xWert & " " & yWert If SelObj.ObjectName = "AcDbCircle" Then 'MsgBox SelObj.ObjectName & " X: " & xWert & " " & "Y: " & yWert ElseIf SelObj.ObjectName = "AcDbPolyline" Then 'MsgBox SelObj.ObjectName & " X: " & xWert & " " & "Y: " & yWert ElseIf SelObj.ObjectName = "AcDbHatch" Then 'MsgBox SelObj.ObjectName & " X: " & xWert & " " & "Y: " & yWert Else 'MsgBox "Punkt" & "X: " & xWert & "Y: " & yWert & vbCr & SelObj.ObjectName AnzahlEntity = AcadApp.ActiveDocument.ModelSpace.Count AcadApp.ActiveDocument.SendCommand ("._-boundary" & vbCr & XYstring & vbCr & vbCr) '& "A" & vbCr & "_Island" & vbCr & "N" & vbCr & "N" & vbCr & "O" & vbCr & "_Polyline" & vbCr & vbCr If AcadApp.ActiveDocument.ModelSpace.Count > AnzahlEntity Then Set NeuesElement = AcadApp.ActiveDocument.ModelSpace(AcadApp.ActiveDocument.ModelSpace.Count - 1) plineArea = plineArea + NeuesElement.Area With AcadApp.ActiveDocument Set hatchObjUmgrenzung = .ModelSpace.AddHatch(PatternType, patternName, bAssociativity) Set Umgrenzung(0) = NeuesElement End With hatchObjUmgrenzung.AppendOuterLoop (Umgrenzung) hatchObjUmgrenzung.Evaluate NeuesElement.Update AcadApp.ZoomExtents End If End If objSelSet.Delete Loop Loop MsgBox "Fehlfläche ist " & plineArea Range("AH2").Value = plineArea End Sub
Mit der If Else Methode wollte ich die einzelnen Objekte abfangen, die er in einem Bereich finden könnte. Nach Abarbeiten der If oder ElseIf Anweisungen, sollte unter Else das eigentlich Wichtige durchgeführt werden. Die Umgrenzung der nicht gefüllten Fläche, Flächenermittlung und Füllen der Fläche mit gleicher Schraffur (siehe Bild im Anhang). Der letzte Teil, ab Else: Fläche ermitteln usw. funktioniert. Soweit ich das beurteilen kann hängt dieses Makro an zwei Sachen. 1. An der If Anweisung - kann ich dieses Problem noch anders angehen? 2. An der Do While Schleife - Hier springt das Makro nach der ersten inneren Schleife aus der äußeren heraus. Dafür habe ich keine Erklärung. Es Durchläuft die äußere Schleife einmal. Die Abbruchbedingung scheint mir richtig zu sein. Könnt Ihr mir helfen? Danke Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |