Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  AutoCAD VBA
  Schrittweise Auswertung der Zeichnung mit SelectAtPoint

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 08:23    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von Carsten1210 an!   Senden Sie eine Private Message an Carsten1210  Schreiben Sie einen Gästebucheintrag für Carsten1210

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

Hi,

Du hast ein End Select bei deiner Select Case-Anweisung vergessen, deshalb bekommst du die Fehlermeldung.

Gruß, Carsten

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Sagu
Mitglied
Dipl - Ing


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 10:44    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 10:46    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Geht es vielleicht über SelectByPolygon?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Carsten1210
Mitglied
staatl. geprüfter Holztechniker


Sehen Sie sich das Profil von Carsten1210 an!   Senden Sie eine Private Message an Carsten1210  Schreiben Sie einen Gästebucheintrag für Carsten1210

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 13:12    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von startrek an!   Senden Sie eine Private Message an startrek  Schreiben Sie einen Gästebucheintrag für startrek

Beiträge: 1361
Registriert: 13.02.2003

.

erstellt am: 15. Mrz. 2007 13:25    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

Moinmoin,

das fehlende 's' sprang mich grade an;-)

Code:
Set ssetObj = AcadApp.ActiveDocument.SelectionSets.Add("Umgrenzung")

lg Nancy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Sagu
Mitglied
Dipl - Ing


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 13:29    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Das wollte ich nicht, werde mit dem "s" reden.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Stelli1
Moderator
Verm.-Ing.


Sehen Sie sich das Profil von Stelli1 an!   Senden Sie eine Private Message an Stelli1  Schreiben Sie einen Gästebucheintrag für Stelli1

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 15:14    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 15:37    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 15. Mrz. 2007 19:37    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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.


Sehen Sie sich das Profil von Stelli1 an!   Senden Sie eine Private Message an Stelli1  Schreiben Sie einen Gästebucheintrag für Stelli1

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 16. Mrz. 2007 10:13    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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


Sehen Sie sich das Profil von startrek an!   Senden Sie eine Private Message an startrek  Schreiben Sie einen Gästebucheintrag für startrek

Beiträge: 1361
Registriert: 13.02.2003

.

erstellt am: 16. Mrz. 2007 10:32    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

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.


Sehen Sie sich das Profil von Stelli1 an!   Senden Sie eine Private Message an Stelli1  Schreiben Sie einen Gästebucheintrag für Stelli1

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

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 Long

AnzahlEntity = 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.


Sehen Sie sich das Profil von Stelli1 an!   Senden Sie eine Private Message an Stelli1  Schreiben Sie einen Gästebucheintrag für Stelli1

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich


code.gif

 
Ü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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 17. Mrz. 2007 11:23    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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 = -1

AnzahlEntity = 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


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 17. Mrz. 2007 13:46    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

oder
Code:
                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


Sehen Sie sich das Profil von Carsten1210 an!   Senden Sie eine Private Message an Carsten1210  Schreiben Sie einen Gästebucheintrag für Carsten1210

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 oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Sagu 10 Unities + Antwort hilfreich

Hi,

Du musst "IAcadHatch" als Typename nehmen.

Die erste Variante zum prüfen, ob ein Selectionset vorhanden ist, sollte eigentlich funktionieren.

Gruß, Carsten

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Sagu
Mitglied
Dipl - Ing


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 18. Mrz. 2007 09:04    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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, selbst­ständig zu arbeiten. Sie möchten echten Erfolg mit­ge­stal­ten. Haben Sie auch einen Arbeit­geber, der das zu schätzen weiß? Rund 1300 Mitarbeitende bei LAMILUX schon! Deswegen sind wir eines der wachs­tums­stärksten Familien­unter­nehmen Ober­frankens und welt­weit führend in unseren Märkten: Wir produ­zieren faser­ver­stärkte Kunst­stoffe für den welt­weiten Bau von Nutz­fahr­zeugen, Caravans oder auch Bussen....

Anzeige ansehenProjektmanagement
Sagu
Mitglied
Dipl - Ing


Sehen Sie sich das Profil von Sagu an!   Senden Sie eine Private Message an Sagu  Schreiben Sie einen Gästebucheintrag für Sagu

Beiträge: 31
Registriert: 11.03.2007

erstellt am: 19. Mrz. 2007 09:28    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


Export.JPG

 
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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz