---

Hallo,
ist dieses in VBA ACAD möglich?
ich erzeuge ein zB Rechteckobjekt per VBA, dann soll dieses Objekt solange kopiert werden bis ich zB die Taste "E" drücke.
Die Flächen der Objekte sollen dabei summiert werden.

Gruß 
Tom

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

---

Hallo Tom,

das kannste mit VB machen. Nur sollte es wohl nicht die Taste E sein sondern wie üblich ESC oder RT.
Hast du denn schon den Code um das Rechteck zu erzeugen oder willst du ein vorhandenes wählen und dann nur kopieren ?

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

---

Hallo Stelli,
nach Stunden des wühlens im Forum und das berühmte try and error Prinzip, habe ich ein fast lauffähigen code zusammengebastet. Die User wollen aber mit der "Ende" Taste abbrechen. Mir ist das egal - wenn die es wollen 

Bei meinem Code Beispiel, wird immer noch nach dem Betätigen der Ende-Taste ein Befehl im Autocad weiter ausgeführt. Habe da wohl noch ein Gedankenfehler drin. Vielleicht sollte ich jetzt erstmal ein Glas Wein trinken, um mein Gehirn zu kühlen 
Weiss du, wie man sofort nach dem Betätigen der ENDE Taste, die Befehlsfolge in ACAD abbricht?
LG
Tom

Code:

---

Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer

Sub test()
Dim test As Double
Dim i As Integer
Dim Antwort
Dim Gesamtflaeche

  On Error GoTo test_Error
  i = 1 'Anzahl Objekte
  test = 0
  Do
   
    If checkkey(vbKeyEnd) = True Then
        Exit Do
    End If
    i = i + 1

    Gesamtflaeche = Gesamtflaeche + rechtlb(5, 5)  'for testing x=5 y=5
    test = rechtlb(5, 5)
    If i = 5 Then Exit Do
  Loop
      Gesamtflaeche = Gesamtflaeche + test   ' adding area
    MsgBox "Gesamtfläche= " & (Format(Gesamtflaeche, "##,##0.00")) & " m²" & " mit " & (i - 0) & " Objekten"
test_exit:
  Exit Sub

test_Error:
    If Err.Number = -2145320928 Or Err.Number = -2147352567 Then
        Antwort = MsgBox("Wollen Sie abbrechen?", vbYesNo, "Hinweis")
        If Antwort = "Ja" Then
            Exit Sub
        Else
            Resume
        End If
      Else
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure test of Modul Allgemein"
        Resume test_exit
      Err.Clear
    End If
End Sub

Function rechtlb(laenge As Double, breite As Double) As Double
   
'Zeichnet Rechteck mit Läne und Breiteangaben
    Dim p1 As Variant
    Dim pl As AcadLWPolyline
    Dim re(0 To 7) As Double
    Dim Antwort
   
'Startpunkt
  On Error GoTo rechtlb_Error

    p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Bitte den Startpunkt wählen: ")

'Rechteckkonstruktion
    re(0) = p1(0): re(1) = p1(1)
    re(2) = p1(0) + breite: re(3) = p1(1)
    re(4) = re(2): re(5) = re(3) + laenge
    re(6) = p1(0): re(7) = re(5)
   
   
    Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(re)
    pl.Closed = True
  'Fläche
    rechtlb = pl.Area

  'On Error GoTo 0
rechtlb_exit:
  Exit Function

rechtlb_Error:
If Err.Number = -2145320928 Or Err.Number = -2147352567 Then
        Antwort = MsgBox("Wollen Sie abbrechen?", vbYesNo, "Hinweis")
        If Antwort = "Ja" Then
            Exit Function
        Else
            Resume
        End If
      Else
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure rechtlb of Modul Allgemein"
        Resume rechtlb_exit
      Err.Clear
    End If
   
End Function

---

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

---

Hallo Tom,

wie schon gesagt. Ich würde es bei den Tasten RT oder ESC belassen.
Dann wäre dein Programmcode fertig.

In dem Augenblick wo du mit ThisDrawing.Utility.GetPoint einen Punkt in AutoCAD abfragst, ist dein Programmcode in VB unterbrochen und reagiert nicht auf eine andere Taste weil AutoCAD die Kontrolle übernommen hat.

Vielleicht versuchst du es mit einem Trick (ungetestet, weil ich das auch nicht gut finde  )
Wenn du vor dem Abfragen des Punktes in AutoCAD einen Timer initialisierts der im Takt prüft ob eine Taste gedrückt wurde, könnstes du per SendKeys ein ESC an AutoCAD schicken um den Befehl zu beenden.

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

---

Hallo Stelli,
vielen Dank fuer deine Hilfe. Ich habe nun mit Escape probiert, leider wird nach dem Escape immer noch ein Zeichenbefehl (hier das Rechtzeichnen) ausgeführt.
d.h. wenn ich nach zwei Rechtecken auf Escape drücke, erwartet ACAD wie du schon sagtest noch immer einen Befehl. Baue ich einen Senkeys mit Esc und einen Enter ein, laeuft es immer noch "schief". Irgendwie ist in der Abbruchroutine noch ein Gedankenfehler bei mir drin.
Kann doch nicht wahr sein, dass es kompliziert ist ,grummel
Tom

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

---

Hallo Tom,

läuft denn der Timer Event wenn du in AutoCAD nach dem Punkt fragst?

Setze doch mal eine MSGBOX in den Code des Timers. Dann kannst du sehen ob AutoCAD den Event zulässt.

Stelli

PS: Welche Sorte Wein ???

------------------
Warum lisp'eln wenn's auch anders geht. 
www.ib-stelberg.de

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

---

Servus,
der Timer scheint zu gehen. Ich poste mal den jetzigen Code Stand. Den Sendkeys ESC mag er nicht, dafuer anscheinend eher die Enter Version:
(der Wein: 2001 Fatalone giolia Del Colle, Primitivo)

Code:

---

Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer

Sub test()
Dim test As Double
Dim i As Integer
Dim Antwort
Dim Gesamtflaeche
Dim loeschen As Integer


  On Error GoTo test_Error
  i = 1 'Anzahl Objekte
  'test = kreisd(10)
  test = 0
  loeschen = 0
  Do
   
    'test = rechtlb(5, 5)
    If checkkey(vbKeyEscape) = True Then
        loeschen = 1
        Exit Do
      Else
       
        i = i + 1
        Gesamtflaeche = Gesamtflaeche + rechtlb(5, 5)
        test = rechtlb(5, 5)
        Debug.Print "fl= " & test
        If test = 0 Then    'Abbruch
            Exit Do
        End If
    End If
    If i = 4 Then Exit Do
  Loop
      If loeschen = 1 Then
       
      End If
      Gesamtflaeche = Gesamtflaeche + test
    MsgBox "Gesamtfläche= " & (Format(Gesamtflaeche, "##,##0.00")) & " m²" & " mit " & (i - 1) & " Objekten"
test_exit:
  Exit Sub

test_Error:
    If Err.Number = -2145320928 Or Err.Number = -2147352567 Then
        Antwort = MsgBox("Wollen Sie abbrechen?", vbYesNo, "Hinweis Test")
        If Antwort = "Ja" Then
            Exit Sub
        Else
            Resume
        End If
      Else
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure test of Modul Allgemein"
        Resume test_exit
      Err.Clear
    End If
End Sub

Function rechtlb(laenge As Double, breite As Double) As Double
   
'Zeichnet Rechteck mit Länge und Breiteangaben
    Dim p1 As Variant
    Dim pl As AcadLWPolyline
    Dim re(0 To 7) As Double
    Dim Antwort
   
'Startpunkt
  On Error GoTo rechtlb_Error

    p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Bitte den Startpunkt wählen: ")

'Rechteckkonstruktion
    re(0) = p1(0): re(1) = p1(1)
    re(2) = p1(0) + breite: re(3) = p1(1)
    re(4) = re(2): re(5) = re(3) + laenge
    re(6) = p1(0): re(7) = re(5)
   
  'Timer
    Dim Pausenlänge, Start, Ende, Gesamtdauer
 
    Pausenlänge = 0.5    ' Dauer festlegen.
    Start = Timer    ' Anfangszeit setzen.
    Do While Timer < Start + Pausenlänge
        If checkkey(vbKeyEscape) = True Then
            Exit Function
        End If
        DoEvents    ' Steuerung an andere Prozesse
            ' abgeben.
           
    Loop
    Ende = Timer    ' Ende festlegen.
    Gesamtdauer = Ende - Start    ' Gesamtdauer berechnen.

   
    Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(re)
    pl.Closed = True
  'Fläche
    rechtlb = pl.Area

 
rechtlb_exit:
  Exit Function

rechtlb_Error:
If Err.Number = -2145320928 Or Err.Number = -2147352567 Then
        Antwort = MsgBox("Wollen Sie abbrechen?", vbYesNo, "Hinweis -rechtlb-")
        If Antwort = vbYes Then
            rechtlb = 0
            Debug.Print rechtlb
           
            SendKeys "~", True
            SendKeys "ESC", True
           
            Exit Function
        Else
            Resume
        End If
      Else
        MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure rechtlb of Modul Allgemein"
        Resume rechtlb_exit
      Err.Clear
    End If
   
End Function

---

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

---

Hallo Tom,

kann ich verstehen. Mit dem Primitivo bekommt man einen Reset locker hin 

Häng doch mal deine DVB an. Der Code ist ja so nicht vollständig.

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

---

diese Fkt hat wohl noch gefehlt. Die ganze DVB dran zu haengen waere zu verwirrend. Weil das meiste garnichst damit zu tuen hat.
Leider ist die Flasche leer. Daher wohl mein Stillstand hier ;-)

Function checkkey(lngKey As Long) As Boolean
'Prueft Tastatureingabe
  If GetAsyncKeyState(lngKey) Then
        checkkey = True
    Else
        checkkey = False
  End If
End Function

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

---

sodele, nach einem heißem Tee mit Schokostueck, scheine ich ein Stueck weiter gekommen zu sein:
Habe im Error handling diese beiden ausgetauscht:
SendKeys "~", True
SendKeys "ESC", True

mit
thisdrawing.sendcommand chr(27)

das scheint besser in ACAD "durchzukommen"

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

---

Hallo Tom,

hatte noch keine Zeit das ganze nachzustellen.

Aber wie es scheint läuft es jetzt bei dir mit dem Timer !?

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

---

da steckt noch ein kleiner Wurm drin. Es wird zwar wieder nach einem Startpunkt gefragt, aber wenn ich dann einen Punkt klicke, wird aber nichts gezeichnet (soll ja auch nicht mehr). Komisch, ich koennte schwoeren, vorhin kam diese Befehlsnachfrage nicht mehr.
Koenntest du dennoch mal bei dir es durchlaufen lassen?

Vielleicht sollte ich fuer nachher noch ne Weinflasche organisieren. Eigentlich muesste Autodesk automatisch als Schmerzensgeld regelmaessig Wein liefern
Gruß
Tom

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

---

Hallo Tom,

habs mal abgespeckt. Es läuft, aber so macht man das nicht.
Mir ist AutoCAD 2mal abgeschmiert.
Machs wie in allen anderen Funktionen mit der RT/ESC.

Aber wie auch immer. Du musst schon ein Timer Kontroll einbinden.
EIne Zählschleife bringt es nicht da sie nicht abgearbeitet wird.

Code:

---

Modul1
Option Explicit
Public E_gedrückt As Boolean

Declare Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer
Sub test()
Dim dbltest As Double
Dim i As Integer
Dim Antwort
Dim Gesamtflaeche
Dim loeschen As Integer

  i = 1    'Anzahl Objekte
  dbltest = 0
  loeschen = 0
  Do
        i = i + 1
        dbltest = rechtlb(5, 5)
        Gesamtflaeche = Gesamtflaeche + dbltest
        If dbltest = 0 Then Exit Do
  Loop
  MsgBox "Gesamtfläche= " & (Format(Gesamtflaeche, "##,##0.00")) & " m²" & " mit " & (i - 1) & " Objekten"
End Sub
Function rechtlb(laenge As Double, breite As Double) As Double
'Zeichnet Rechteck mit Länge und Breiteangaben
    Dim p1 As Variant
    Dim pl As AcadLWPolyline
    Dim re(0 To 7) As Double
    Dim Antwort
   
'Startpunkt
    ' Timer initialiseren
    ' Beim Timer Event werden die Tasten abgefragt
    E_gedrückt = False
    UserForm1.xTimer1.SetTime = 1000
   
    On Error GoTo rechtlb_Error
    p1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "Bitte den Startpunkt wählen: ")
    ' Wurde während des Befehls die Taste E gedrückt
    If E_gedrückt = True Then
      Exit Function
    End If
    On Error GoTo 0
   
    ' Timer abschalten
    UserForm1.xTimer1.SetTime = 0

'Rechteckkonstruktion
    re(0) = p1(0): re(1) = p1(1)
    re(2) = p1(0) + breite: re(3) = p1(1)
    re(4) = re(2): re(5) = re(3) + laenge
    re(6) = p1(0): re(7) = re(5)
   
    Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(re)
    pl.Closed = True
    pl.Update
 
  'Fläche
    rechtlb = pl.Area

 
rechtlb_exit:
  Exit Function

rechtlb_Error:
If Err.Number Then
        Antwort = MsgBox("Wollen Sie abbrechen?", vbYesNo, "Hinweis -rechtlb-")
        If Antwort = vbYes Then
            rechtlb = 0
            'Timer abschalten
            UserForm1.xTimer1.SetTime = 0
            Exit Function
        Else
            Resume
        End If
End If
   
End Function

Function checkkey(lngKey As Long) As Boolean
'Prueft Tastatureingabe
  If GetAsyncKeyState(lngKey) Then
        checkkey = True
    Else
        checkkey = False
  End If
End Function

---

Code:

---

Userform mit Timer
Private Sub xTimer1_ZeitIstUm(Interval As Long)
    If checkkey(69) Then
        E_gedrückt = True
        SendKeys Chr$(27)
    End If
End Sub

---

Viel Spass damit 

Übringens meine Primitivo Vorräte sind auch am Ende 

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

---

mal wieder ich ....

UserForm1.xTimer1.SetTime , öhm - was mache ich denn damit? userform, das verstehe ich noch. aber was ist mit xtimer1.setTime , das kann ich nicht nachvollziehen.

wie sähe es denn nur mit esc/RT aus?

ich bekomme dein Beispiel wegen diesem UserForm1.xTimer1.SetTime nicht zum laufen. 
aber du hast sicherlich noch genuegend andere gute Weine 

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

---

Hallo Tom,

so meine letzte Version. Ist mal auf das wesentliche reduziert und läüft einwandfrei.
Ich würde allerdings noch die Blöde Frage ob der Benutzer wirklich beenden will entfernen. Mir geht so was auf den Keks.

Code:

---

'' Modul
Option Explicit
Sub test()
    Dim Fläche As Double
    Dim GesamtFläche As Double
    Dim Anzahl As Integer
   
    ThisDrawing.Utility.Prompt Chr$(10) & "*** Flächen erfassen ***"
    Do
        ' Rechteck auf Benutzereingabe setzen
        Fläche = rechtlb(5, 5)
        If Fläche = 0 Then Exit Do
       
        ' Statistik
        Anzahl = Anzahl + 1
        GesamtFläche = GesamtFläche + Fläche
        ThisDrawing.Utility.Prompt Chr$(10) & "Gesamtfläche= " & (Format(GesamtFläche, "##,##0.00")) & " m²" & " mit " & Anzahl & " Objekten"
    Loop
 
End Sub

Function rechtlb(laenge As Double, breite As Double) As Double
    'Zeichnet Rechteck mit Länge und Breiteangaben
    Dim p1 As Variant
    Dim pl As AcadLWPolyline
    Dim re(0 To 7) As Double
    Dim Antwort
   
    'Startpunkt
    On Error GoTo rechtlb_Error
    p1 = ThisDrawing.Utility.GetPoint(, " / Bitte den Startpunkt wählen: ")
    On Error GoTo 0
   
    'Rechteckkonstruktion
    re(0) = p1(0): re(1) = p1(1)
    re(2) = p1(0) + breite: re(3) = p1(1)
    re(4) = re(2): re(5) = re(3) + laenge
    re(6) = p1(0): re(7) = re(5)
   
    Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(re)
    pl.Closed = True
    pl.Update
 
    'Fläche
    rechtlb = pl.Area
rechtlb_exit:
    Exit Function

rechtlb_Error:
    ' benutzer hat Funktion beendet
    If MsgBox("Wirklich schon beenden ?", vbQuestion + vbYesNo, "Ganz wichtige Frage") = vbYes Then
        Exit Function
    Else
        Resume
    End If
   
End Function

---

Viel Spass damit

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

---

oohhhhh, da trifft es wirklich zu: "warum so kompliziert,wenn es einfacher geht!"

vielen Dank, Stelli, du bist genial!

dankeee schöööön
werde heute Abend ein Glas auf dich trinken
Tom

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