---

Hallo Zusammen,

ich habe in der Firma ein Projekt, wo ich gerne die Prüfmaße in eine Excel übertragen möchte.
Da es hier im Forum ein ähnliches Thema gab, habe ich die Makrovorlage genommen und versucht abzuändern.

Problem ist, dass Excel nur die Zahl überträgt, leider ohne Toleranzen oder Durchmesserzeichen.
Ich habe leider keine Ahnung von VBA und mein Kollege weiß auch nicht weiter.
Eventuell kann mir jemand helfen und es ist hoffentlich nur eine Kleinigkeit.
Inreto macht das was wir wollen, aber ich wollte es selber versuchen.

Dim swApp As Object
Dim Part As Object

Dim Gtol As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Dim view As Object
Dim DisplayDimension As Object
Dim Dimension As Object
Dim Wert As Double
Dim tol As Variant
Dim dimstring As String
Dim myTable As Object
Dim myTextFormat As Object
Dim Präfix As String


Sub main()

    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
   
    Set view = Part.GetFirstView
    nr = 1
   
    '########################################################################################################################
    '-> Exceldatei öffnen
    Dim oExcel As Object
     
    On Error Resume Next
   
    Set oExcel = GetObject(, "Excel.Application") '-> Versuch einen Verweis auf Excel zu bekommen
   
    If Err.Number <> 0 Then '-> Wenn ein Fehler auftritt dann läuft Excel noch nicht
        Set oExcel = CreateObject("excel.application") '-> Wenn Excel noch nicht läuft, dann wird es gestartet
        Err.Clear '-> Error zurücksetzen
    End If
    oExcel.Visible = True
   
    Dim sDateiPfad As String: sDateiPfad = "c:\test.xlsx" '-> Dateipfad
    oExcel.workbooks.open (sDateiPfad) '-> Datei öffnen

    '########################################################################################################################
   
    '-> Verareitung
    Do While Not view Is Nothing
        Set DisplayDimension = view.GetFirstDisplayDimension
       
        For j = 0 To view.GetDimensionCount - 1
            Set Dimension = DisplayDimension.GetDimension
            If DisplayDimension.Inspection = 1 Then
                Wert = Dimension.SystemValue
                Dim tol(1) As Double
               
                lWarning = Dimension.Tolerance.GetMinValue2(tol(0))
                lWarning = Dimension.Tolerance.GetMaxValue2(tol(1))
               
                Set btol = Dimension.Tolerance
                Präfix = DisplayDimension.GetText(swDimensionTextPrefix)
               
                If Dimension.GetToleranceType = swTolSYMMETRIC Then tol(0) = -tol(1)
                If Dimension.GetToleranceType = swTolFIT Then
                    BohrPass = btol.GetHoleFitValue
                    WellPass = btol.GetShaftFitValue
                End If
               
               
               
                'Bemaßung nummerieren
                dimstring = "[" + CStr(nr) + "] " & Präfix
                DisplayDimension.SetText swDimensionTextPrefix, dimstring
           
               
                '-> Wert in Excel eintragen
                oExcel.Worksheets(1).Cells(nr, 1).Value = nr
                oExcel.Worksheets(1).Cells(nr, 2).Value = Dimension.Value
                oExcel.Worksheets(1).Cells(nr, 3).Value = Dimension.Tolerance
                oExcel.Worksheets(1).Cells(nr, 9).Value = Dimension.GetText(7)
                oExcel.Worksheets(1).Cells(nr, 10).Value = Dimension.GetText(8)
               
                nr = nr + 1
               
     
             
            End If
           
            Set DisplayDimension = DisplayDimension.GetNext
       
        Next
       
        Set view = view.GetNextView
       
    Loop
   
    boolstatus = Part.ForceRebuild3(True)
End Sub

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

---

Guten Morgen,

hat keiner eine Ahnung wie ich die Toleranzen und Ø Zeichen mit in Excel übertragen bekomme 

Liebe Grüße 

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

---

Das kommt mir doch bekannt vor... 

Die Toleranz- und Durchmesserzeichen stecken als string in der Variable "Präfix". Die müsst ihr nur in Excel eintragen lassen...

Gruß, Jens

------------------
CSWE =)

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

---

Hallo Jens,

vielen Dank für deine Hilfe.
Was bedeutet nur in Excel eintragen lassen?

Liebe Grüße
Micha

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

---

Zitat:

---

Original erstellt von th3kingz:
Was bedeutet nur in Excel eintragen lassen?

---

Entweder als Text in eine eigene Spalte,z.B.:

Code:

---

oExcel.Worksheets(1).Cells(nr, 11).Value = Präfix

---

oder direkt vor den Wert:

Code:

---

oExcel.Worksheets(1).Cells(nr, 2).Value = Präfix & Dimension.Value

---

Gruß, Jens

------------------
CSWE =)

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

---

Guten Morgen Jens,

vielen Dank für deine Hilfe, ich bin schon wieder ein wenig weiter.
Leider wird in Excel jetzt <MOD-DIAM> angezeigt, anstatt ein Durchmesserzeichen. Aber das bekomme ich iwie schon hin.

Um die Toleranzen mitzunehmen habe ich folgendes eingegeben:

oExcel.Worksheets(1).Cells(nr, 4).Value = Dimension.GetToleranceValues

Er zeigt mir aber nur die untere Toleranz an, wie mache ich es, dass er mir untere und obere Toleranz in Excel anzeigt?

Liebe Grüße
Micha

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

---

Zitat:

---

Original erstellt von th3kingz:
Leider wird in Excel jetzt <MOD-DIAM> angezeigt, anstatt ein Durchmesserzeichen. Aber das bekomme ich iwie schon hin.

---

SolidWorks wandelt das intern selbst um. Für deinen Fall musst du sowas hier machen:

Code:

---

If Präfix = "<MOD-DIAM>" then Präfix = "Ø"

---

(Das Zeichen aus der Zeichentabelle kopieren.)

Das wird dir an mehreren Stellen passieren, z.B. bei ± auch...

Zitat:

---

Um die Toleranzen mitzunehmen habe ich folgendes eingegeben:

oExcel.Worksheets(1).Cells(nr, 4).Value = Dimension.GetToleranceValues

Er zeigt mir aber nur die untere Toleranz an, wie mache ich es, dass er mir untere und obere Toleranz in Excel anzeigt?

---

GetToleranceValues liefert dir ein Array mit oberer und unterer Toleranz. Die musst du auch einzeln abfragen (tol(0) und tol(1)).

Ich häng dir mal den Ausschnitt aus meinem Makro an, mit dem die Werte ausgelesen werden. Da kannst du das (vielleicht ;) ) nachvollziehen:

(mytable ist hier die Prüfmasstabelle auf der Zeichnung. Bei dir würde an der Stelle die Ziel-Excel-Zelle stehen.)

Code:

---

        'Bemaßungen
        Set DisplayDimension = View.GetFirstDisplayDimension
       
        For j = 0 To View.GetDimensionCount - 1
            Set Dimension = DisplayDimension.GetDimension
            If DisplayDimension.Inspection = 1 Then
                wert = Dimension.SystemValue
               
                BemTyp = Dimension.GetType
               
                If BemTyp = 1 Then  'Winkel
                    Typ = "Winkel"
                    wert = 360 / (2 * pi) * wert
                    wert = Round(wert, 3)
                Else
                    Typ = "Länge"
                    wert = Round(wert, 6)  'Rundung, da bei Maß in Baugruppen zwischen 2 Bauteilen Gleitkommafehler an 12. Nachkommastelle auftritt
                End If
               
                tol = Dimension.GetToleranceValues
                If BemTyp = 1 Then  'Winkel
                  tol(0) = 360 / (2 * pi) * tol(0)
                  tol(0) = Round(tol(0), 3)
                  tol(1) = 360 / (2 * pi) * tol(1)
                  tol(1) = Round(tol(1), 3)
                End If
                 
                Set btol = Dimension.Tolerance
                Präfix = DisplayDimension.GetText(swDimensionTextPrefix)
                If Präfix = "<MOD-DIAM>" Then Typ = "<MOD-DIAM>"
               
                If Dimension.GetToleranceType = swTolSYMMETRIC Then tol(0) = -tol(1)
                If Dimension.GetToleranceType = swTolFIT Then
                    BohrPass = btol.GetHoleFitValue
                    WellPass = btol.GetShaftFitValue
                End If
               
                Z = nr + 1      'Aktueller Zeilenindex
               
                If nr > 1 Then
                    boolstatus = myTable.InsertRow(swTableItemInsertPosition_After, Z - 1)
                    boolstatus = myTable.UnmergeCells(Z, 0)
                End If
               
                ' Zellen mit Werten belegen, Umwandlung in mm
                myTable.Text(Z, 0) = "#" & nr                    'Nummer
                myTable.Text(Z, 1) = Typ
               
                If Dimension.GetToleranceType = swTolFIT Then  'Wenn Passung
                    myTable.Text(Z, 2) = Präfix & wert * 1000 & " " & BohrPass & WellPass
                ElseIf Dimension.GetToleranceType = swTolSYMMETRIC Then 'Wenn symm.
                    If BemTyp = 1 Then 'Winkel
                        myTable.Text(Z, 2) = Präfix & wert & "° ±" & tol(1) & "°"
                    Else
                        myTable.Text(Z, 2) = Präfix & wert * 1000 & " ±" & tol(1) * 1000
                    End If
                Else
                    If BemTyp = 1 Then  'Winkel
                        myTable.Text(Z, 2) = Präfix & wert & "° +" & tol(1) & "° " & IIf(tol(0) <> 0, tol(0) & "°", "")
                    Else
                        myTable.Text(Z, 2) = Präfix & wert * 1000 & " +" & tol(1) * 1000 & " " & IIf(tol(0) <> 0, tol(0) * 1000, "")
                    End If
                End If
               
                If BemTyp = 1 Then  'Winkel
                    myTable.Text(Z, 3) = Präfix & (wert + tol(1)) & "°"        'oberes Grenzmaß
                    myTable.Text(Z, 4) = Präfix & (wert + tol(0)) & "°"        'unteres Grenzmaß
                Else
                    myTable.Text(Z, 3) = Präfix & (wert + tol(1)) * 1000          'oberes Grenzmaß
                    myTable.Text(Z, 4) = Präfix & (wert + tol(0)) * 1000        'unteres Grenzmaß
                End If
             
                'Bemaßung nummerieren
                dimstring = "#" + CStr(nr)
                DisplayDimension.SetText swDimensionTextCalloutAbove, dimstring
                nr = nr + 1
               
            End If
           
            pos = ""
            Set DisplayDimension = DisplayDimension.GetNext
        Next

---

------------------
CSWE =)

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

---

Guten Morgen 

Das mit dem Ø Zeichen hatte ich so auch schon probiert. Da fehlt sicher noch etwas, weil angezeigt wird es immer noch nicht.
Ich hatte auch deinen Text letzte Woche vorher schon einmal kopiert aber es hatte keine Änderung ergeben. Und für mich als Laie bedeutet es, ich lösche es wieder... 

Muss ich alle myTable.Text löschen? und durch einen Verweis auf Excel ergänzen? Ich hab da schon getestet aber danach ist meine Exceldatei immer leer. kannst du mir bitte mit dem Verweis auf Excel helfen?

Liebe Grüße 

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

---

Zitat:

---

Original erstellt von th3kingz:
Das mit dem Ø Zeichen hatte ich so auch schon probiert. Da fehlt sicher noch etwas, weil angezeigt wird es immer noch nicht.
Ich hatte auch deinen Text letzte Woche vorher schon einmal kopiert aber es hatte keine Änderung ergeben. Und für mich als Laie bedeutet es, ich lösche es wieder...  

---

Mit F8 kannst du im Makro-Editor Schritt für Schritt durch das Makro gehen und siehst, was er gerade ausgelesen hat (Lokal-Fanster unter "Ansicht" einschalten, dann kannst du dir anschauen, welche Variable gerade welchen Wert hat).

Zitat:

---

Muss ich alle myTable.Text löschen? und durch einen Verweis auf Excel ergänzen?

---

Genau so...

Ich hab dir das mal zusammengefügt. So sollte es zumindest irgendetwas schreiben. :D Was genau und wohin musst du dann halt noch anpassen. ;)

Code:

---

Dim swApp As Object
Dim Part As Object

Dim Gtol As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Dim view As Object
Dim DisplayDimension As Object
Dim Dimension As Object
Dim Wert As Double
Dim tol As Variant
Dim dimstring As String
Dim myTable As Object
Dim myTextFormat As Object
Dim Präfix As String

Sub main()

    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
 
    Set view = Part.GetFirstView
    nr = 1
 
    '########################################################################################################################
    '-> Exceldatei öffnen
    Dim oExcel As Object
   
    On Error Resume Next
 
    Set oExcel = GetObject(, "Excel.Application") '-> Versuch einen Verweis auf Excel zu bekommen
 
    If Err.Number <> 0 Then '-> Wenn ein Fehler auftritt dann läuft Excel noch nicht
        Set oExcel = CreateObject("excel.application") '-> Wenn Excel noch nicht läuft, dann wird es gestartet
        Err.Clear '-> Error zurücksetzen
    End If
    oExcel.Visible = True
 
    Dim sDateiPfad As String: sDateiPfad = "c:\test.xlsx" '-> Dateipfad
    oExcel.workbooks.open (sDateiPfad) '-> Datei öffnen

    '########################################################################################################################
 
    '-> Verarbeitung
    Do While Not view Is Nothing
Set DisplayDimension = View.GetFirstDisplayDimension

nr = 1

        For j = 0 To View.GetDimensionCount - 1
            Set Dimension = DisplayDimension.GetDimension
            If DisplayDimension.Inspection = 1 Then
                wert = Dimension.SystemValue
             
                BemTyp = Dimension.GetType
             
                If BemTyp = 1 Then  'Winkel
                    Typ = "Winkel"
                    wert = 360 / (2 * pi) * wert
                    wert = Round(wert, 3)
                Else
                    Typ = "Länge"
                    wert = Round(wert, 6)  'Rundung, da bei Maß in Baugruppen zwischen 2 Bauteilen Gleitkommafehler an 12. Nachkommastelle auftritt
                End If
             
                tol = Dimension.GetToleranceValues
                If BemTyp = 1 Then  'Winkel
                  tol(0) = 360 / (2 * pi) * tol(0)
                  tol(0) = Round(tol(0), 3)
                  tol(1) = 360 / (2 * pi) * tol(1)
                  tol(1) = Round(tol(1), 3)
                End If
               
                Set btol = Dimension.Tolerance
                Präfix = DisplayDimension.GetText(swDimensionTextPrefix)
                If Präfix = "<MOD-DIAM>" Then Typ = "<MOD-DIAM>"
             
                If Dimension.GetToleranceType = swTolSYMMETRIC Then tol(0) = -tol(1)
                If Dimension.GetToleranceType = swTolFIT Then
                    BohrPass = btol.GetHoleFitValue
                    WellPass = btol.GetShaftFitValue
                End If
             
                ' Zellen mit Werten belegen, Umwandlung in mm
                oExcel.Worksheets(1).Cells(nr, 1) = "#" & nr                    'Nummer
                oExcel.Worksheets(1).Cells(nr, 2) = Typ
             
                If Dimension.GetToleranceType = swTolFIT Then  'Wenn Passung
                    oExcel.Worksheets(1).Cells(nr, 3) = Präfix & wert * 1000 & " " & BohrPass & WellPass
                ElseIf Dimension.GetToleranceType = swTolSYMMETRIC Then 'Wenn symm.
                    If BemTyp = 1 Then 'Winkel
                        oExcel.Worksheets(1).Cells(nr, 3) = Präfix & wert & "° ±" & tol(1) & "°"
                    Else
                        oExcel.Worksheets(1).Cells(nr, 3) = Präfix & wert * 1000 & " ±" & tol(1) * 1000
                    End If
                Else
                    If BemTyp = 1 Then  'Winkel
                        oExcel.Worksheets(1).Cells(nr, 3) = Präfix & wert & "° +" & tol(1) & "° " & IIf(tol(0) <> 0, tol(0) & "°", "")
                    Else
                        oExcel.Worksheets(1).Cells(nr, 3) = Präfix & wert * 1000 & " +" & tol(1) * 1000 & " " & IIf(tol(0) <> 0, tol(0) * 1000, "")
                    End If
                End If
             
                If BemTyp = 1 Then  'Winkel
                    oExcel.Worksheets(1).Cells(nr, 4) = Präfix & (wert + tol(1)) & "°"        'oberes Grenzmaß
                    oExcel.Worksheets(1).Cells(nr, 5) = Präfix & (wert + tol(0)) & "°"        'unteres Grenzmaß
                Else
                    oExcel.Worksheets(1).Cells(nr, 4) = Präfix & (wert + tol(1)) * 1000          'oberes Grenzmaß
                    oExcel.Worksheets(1).Cells(nr, 5) = Präfix & (wert + tol(0)) * 1000        'unteres Grenzmaß
                End If
           
                'Bemaßung nummerieren
                dimstring = "[" + CStr(nr) + "] " & Präfix
                DisplayDimension.SetText swDimensionTextPrefix, dimstring

                nr = nr + 1
             
            End If

            Set DisplayDimension = DisplayDimension.GetNext
        Next

Set view = view.GetNextView
    Loop
 
    boolstatus = Part.ForceRebuild3(True)
End Sub

---

Gruß, Jens

------------------
CSWE =)

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

---

Hallo Jens,

super ich danke dir sehr.
Das mit dem Ø Zeichen klappt noch nicht, sonst sieht es denke ich ganz gut aus  

[Diese Nachricht wurde von th3kingz am 17. Jun. 2019 editiert.]

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

---

Beim Typ zeigt er nun das Ø Zeichen an.
Bei den Werten steht vorher aber immer noch das <MOD-DIAM>.
Wie kann ich das bei der unteren und oberen Toleranz noch weg bekommen?

Und vorher konnte ich z.B 6 Maße als Prüfmaß kennzeichnen und er hat auch 6 Maße in Excel eingetragen,
nun zählt er 1 und 2 Durchmesser und 1 und 2 Länge anstatt daraus 3 und 4 zu machen...
Und er trägt auch nur die 2 Ø Werte in die Excel Tabelle ein.

Gibt es dazu noch die Möglichkeit nachdem er die Prüfmaße nummeriert hat, dies zu prüfen?
Weil wenn ich das Makro öfters darüber laufen lasse dann sieht es iwann wie folgt aus I1I I1I I1I I1I

Liebe Grüße
Micha

[Diese Nachricht wurde von th3kingz am 17. Jun. 2019 editiert.]

[Diese Nachricht wurde von th3kingz am 17. Jun. 2019 editiert.]

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

---

Ich zerlege die Frage mal zum besseren Verständnis:

Zitat:

---

Original erstellt von th3kingz:

1.
Beim Typ zeigt er nun das Ø Zeichen an.
Bei den Werten steht vorher aber immer noch das <MOD-DIAM>.
Wie kann ich das bei der unteren und oberen Toleranz noch weg bekommen?

2.
Und vorher konnte ich z.B 6 Maße als Prüfmaß kennzeichnen und er hat auch 6 Maße in Excel eingetragen,
nun zählt er 1 und 2 Durchmesser und 1 und 2 Länge anstatt daraus 3 und 4 zu machen...
Und er trägt auch nur die 2 Ø Werte in die Excel Tabelle ein.

3.
Gibt es dazu noch die Möglichkeit nachdem er die Prüfmaße nummeriert hat, dies zu prüfen?
Weil wenn ich das Makro öfters darüber laufen lasse dann sieht es iwann wie folgt aus I1I I1I I1I I1I

---

Für die Punkte 1 und 3 sollte es ausreichend sein, wenn du die Zeile Präfix= Displaydimension...

durch die hier ersetzt:

Code:

---

Präfix = DisplayDimension.GetText(swDimensionTextPrefix)
Präfix = right(Präfix,len(Präfix)-instrrev(Präfix,"]"))

---

Der Schnipsel scheidet alles vor (und inkl. des) "]" weg.

Zu 2.: Da lässt mich meine Glaskugel im Stich. Die globale Zählvariable ist "nr" und die wird für jede Prüf-Bemaßung erhöht und zwischendrin auch nirgends zurückgesetzt. theoretisch jedenfalls... 

Gruß, Jens

------------------
CSWE =)

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

---

Guten Morgen,

Ø klappt leider immer noch nicht. Hab auch nochmal ein komplett neues Makro gespeichert mit dem was du alles geschrieben hast. Mit der Präfixerweiterung von dir werden Leerzeichen in das Prüfmaß gebracht. Bedeutet also nach 10 x Makro durchlaufen hat man 10 Leerzeichen zwischen Nr. und Wert.

Bei dem Abschnitt hatte ich gestern noch & Präfix entfernt und danach hat er die Nummern nicht mehr doppelt vergeben. Dachte das hier vllt der Fehler liegt warum er nicht mehr die Prüfmaße alle richtig zählt und einträgt, war aber leider nicht so.

'Bemaßung nummerieren
                dimstring = "[" + CStr(nr) + "] " & Präfix
                DisplayDimension.SetText swDimensionTextPrefix, dimstring

                nr = nr + 1

Er trägt weiterhin nur die Prüfmaße mit Ø Zeichen ein. Wenn ich aber diese Maße entferne, dann zeigt er auch wieder die Längenmaße an.
Sehr komisch alles.

Ich hatte gestern bei den Toleranzen auch versucht einfach das Präfix zu entfernen, weil ich somit auch das <MOD-DIAM> entferne, aber leider hat der Wert mit der Toleranz dann nicht mehr gestimmt.

Liebe Grüße
Micha

Edit: Ich habe das Problem gelöst, dass nicht alle Prüfmaße angezeigt wurden.
Es lag an dem nr = 1 unter Set DisplayDimension = view,GetFirstDisplayDimension

Edit2: Das Problem mit den Ø Zeichen wurde auch gelöst.
Es wurde folgendes eingefügt: Präfix = Replace(Präfix, "<MOD-DIAM>", "Ø")

Jetzt funktioniert das Makro erst einmal so wie ich mir das vorgestellt habe, sicherlich werden jetzt beim weiteren testen noch Kleinigkeiten auffallen.
Ich danke dir für deine wundervolle Hilfe  Ich denke aber ich werde mich sicher noch mal melden ^^

Liebe Grüße
Micha

[Diese Nachricht wurde von th3kingz am 18. Jun. 2019 editiert.]

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

---

Zitat:

---

Original erstellt von th3kingz:
Mit der Präfixerweiterung von dir werden Leerzeichen in das Prüfmaß gebracht. Bedeutet also nach 10 x Makro durchlaufen hat man 10 Leerzeichen zwischen Nr. und Wert.

---

Hab das Leerzeichen von dir  hinter der Klammer übersehen. Bitte mal eine -1 ergänzen:

Code:

---

Präfix = right(Präfix,len(Präfix)-instrrev(Präfix,"]")-1)

---

Zitat:

---

Edit: Ich habe das Problem gelöst, dass nicht alle Prüfmaße angezeigt wurden.
Es lag an dem nr = 1 unter Set DisplayDimension = view,GetFirstDisplayDimension

---

Zitat:

---

Ø klappt leider immer noch nicht.

---

Hast du den Typ, der ja übertragen wird, schon ersetzt? Hatte ich in meinem Code auch noch nicht drin.

Code:

---

If Präfix = "<MOD-DIAM>" Then Typ = "Ø"
If Präfix = "<MOD-DIAM>" then Präfix = "Ø"

---

Gruß, Jens

------------------
CSWE =)

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

---

Das Problem mit dem Ø Zeichen habe ich schon gelöst gehabt.

          Präfix = Replace(Präfix, "<MOD-DIAM>", "Ø"

Das was du eben geschrieben hast, hätte aber auch nicht funktioniert. Zumindestens bei mir nicht ^^

Ich bin gerade glücklich, da ich jetzt endlich intensiv testen kann  

Kannst du mir noch zeigen wie man die ID auslesen kann, wäre ja sehr sinnvoll, wenn man diese auch in Excel übertragen könnte.

[Diese Nachricht wurde von th3kingz am 18. Jun. 2019 editiert.]

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

---

Zitat:

---

Original erstellt von th3kingz:
Kannst du mir noch zeigen wie man die ID auslesen kann, wäre ja sehr sinnvoll, wenn man diese auch in Excel übertragen könnte.

---

Was meinst du mit ID? Hier findest du alles, was man in der API mit so einer Bemaßung anstellen kann...

Und mir ist gerade aufgefallen, dass der Präfix, falls keine "]" drin ist, durch das -1 jetzt zu kurz wird. Da muss noch eine kleine Abfrage hin:

Code:

---

If InStr(Präfix, "]") > 0 Then Präfix = Right(Präfix, Len(Präfix) - InStrRev(Präfix, "]") - 1)

---

Gruß, Jens

------------------
CSWE =)

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

---

ID.png

Mir ist kein Fehler aufgefallen, dass es zu kurz wird. Muss ich mal schauen.

Die ID ist als Bild angehängt.

Liebe Grüße
Micha

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

---

Zitat:

---

Original erstellt von th3kingz:
Die ID ist als Bild angehängt.

---

Meine Glaskugel vermutet, dass das eine Eigenschaft ist, die aus dem referenzierten 3D-Modell kommt. Dafür gibt es auch Code. ;)

In die Variablendeklaration muss:

Code:

---

    Dim swCustPropMgr As CustomPropertyManager
    Dim val As String
    Dim ID As String          'Edit: Muss natürlich ID statt Descr heißen. Sollte aber auch so gehen. :D

---

und unten vor End Sub

Code:

---

   'Modell holen und Eigenschaft auslesen
    Set View = Part.GetFirstView
    Set View = View.GetNextView
   
    ViewName = View.Name
    RefModelName = View.GetReferencedModelName
   
    Select Case UCase(Right(RefModelName, 6))
    Case "SLDPRT"
        SWXTypeOfFile = swDocPART
    Case "SLDASM"
        SWXTypeOfFile = swDocASSEMBLY
    Case "SLDDRW"
        SWXTypeOfFile = swDocDRAWING
    Case Else
        SWXTypeOfFile = swDocNONE
    End Select
   
    If SWXTypeOfFile = swDocNONE Then
        MsgBox "Leere Zeichnung!", vbCritical, "Fehler!"
        End
    End If
   
    ConfigName = View.ReferencedConfiguration
   
    Set model = swApp.OpenDoc(RefModelName, SWXTypeOfFile)
    Set model = swApp.ActivateDoc2(RefModelName, True, nErrors)
    Set swCustPropMgr = model.Extension.CustomPropertyManager(Empty)
   
    retval = swCustPropMgr.Get4("ID", False, val, ID)

---

De Eigenschaftsname musst du evtl. anpassen ("ID"). Die Variable ID dann wie die Prüftexte mit übertragen.

Gruß, Jens

------------------
CSWE =)

[Diese Nachricht wurde von CAD-Maler am 18. Jun. 2019 editiert.]

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

---

Durchmesserweg.png Toleranz.png

Mit dir ID habe ich mich jetzt noch nicht beschäftigt.
Vielleicht kann deine grandiose Glaskugel mir aber trotzdem helfen 

Ich habe zuerst mit 2 Zeichnungen von mir getestet und es war auch alles gut.
Nun öffne ich aber andere Zeichnungen aus dem PDM von Kollegen und da erscheint ein merkwürdiger Fehler.
Ich habe mal ein Bild angehängt. Und zwar markiere ich meine Prüfmaße und lasse das Makro durchlaufen,
Excel öffnet sich und die Ø Zeichen sind richtig vorhanden, wenn ich jetzt aber auf die Zeichnung schaue haut er mir willkürlich einige Ø Zeichen einfach weg. Dementsprechend stimmt die Zeichnung nicht mehr und beim zweiten mal Makro ausführen erkennt er natürlich keine Ø Zeichen mehr weil sie nicht mehr vorhanden sind.

Ein weiteres kleineres Problem gibt es bei bestimmten Toleranzen. Wenn ich zweiseitige Toleranz angegeben habe, aber trotzdem beide Toleranzen positiv oder negativ sind dann kann er mir das im Excel nicht richtig darstellen, die Toleranzen aber trotzdem richtig berechnen.

Liebe Grüße
Micha

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

---

2019-06-18_Toleranz.png

Zitat:

---

Original erstellt von th3kingz:
Ich habe zuerst mit 2 Zeichnungen von mir getestet und es war auch alles gut.
Nun öffne ich aber andere Zeichnungen aus dem PDM von Kollegen und da erscheint ein merkwürdiger Fehler.
Ich habe mal ein Bild angehängt. Und zwar markiere ich meine Prüfmaße und lasse das Makro durchlaufen,
Excel öffnet sich und die Ø Zeichen sind richtig vorhanden, wenn ich jetzt aber auf die Zeichnung schaue haut er mir willkürlich einige Ø Zeichen einfach weg. Dementsprechend stimmt die Zeichnung nicht mehr und beim zweiten mal Makro ausführen erkennt er natürlich keine Ø Zeichen mehr weil sie nicht mehr vorhanden sind.

---

http://forum.cad.de/foren/ubb/Forum2/HTML/032152.shtml#000015 ;)

Zitat:

---

Ein weiteres kleineres Problem gibt es bei bestimmten Toleranzen. Wenn ich zweiseitige Toleranz angegeben habe, aber trotzdem beide Toleranzen positiv oder negativ sind dann kann er mir das im Excel nicht richtig darstellen, die Toleranzen aber trotzdem richtig berechnen.

---

Stimmt. Ist bei meiner Variante auch so. Ist ja auch nicht fertigungsgerecht bemaßt... 

Hier der angepasste Code für mein Makro. Die entsprechende Anpassung für dein Makro machst du mal schön selbst. 

Code:

---

                    'Vorzeichen auslesen
                    V_obere = IIf(tol(1) < 0, "", "+")
                    V_untere = IIf(tol(0) < 0, "", "+")
                   
                    If BemTyp = 1 Then
                        myTable.Text(Z, 2) = Präfix & wert & "° " & V_obere & tol(1) & "° " & V_untere & IIf(tol(0) <> 0, tol(0) & "°", "")
                    Else
                        myTable.Text(Z, 2) = Präfix & wert * 1000 & " " & V_obere & tol(1) * 1000 & " " & V_untere & IIf(tol(0) <> 0, tol(0) * 1000, "")
                    End If

---

Wichtig ist, dass bei positiven unteren Toleranzen dann immer ein "+" davor eingetragen wird, sonst macht SWX automatisch eine Minus-Toleranz draus. (siehe Bild)

Gruß, Jens

------------------
CSWE =)

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

---

Hallo th3kingz

schau dir doch mal das Prüfmass-Marko aus diesem Beitrag an.

Vielleicht findest du da noch eine Lösung für das eine oder andere Problem.

Gruß und viel Erfolg

OLL

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

---

Hallo,

dieses makro hatten ich schon vor Wochen geladen, aber überhaupt nicht zum laufen bekommen...

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

---

Mas.png

Hallo Jens,

das mit den Toleranzen klappt jetzt gut bei zweiseitigen Toleranzen.
Wenn die obere oder untere Toleranz 0 ist dann funktioniert es leider nicht mehr richtig.

Deinen Verweis auf einen vorherigen Beitrag von dir habe ich gesehen und es steht auch alles so im Makro, aber trotzdem haut er mir manchmal die Ø Zeichen weg, aber halt nicht bei allen Zeichnungen.

Liebe Grüße
Micha

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

---

Zitat:

---

Original erstellt von th3kingz:
Wenn die obere oder untere Toleranz 0 ist dann funktioniert es leider nicht mehr richtig.

---

Dann halt so:

Code:

---

'Vorzeichen auslesen
      V_obere = IIf(tol(1) <= 0, "", "+")
      V_untere = IIf(tol(0) <= 0, "", "+")

---

Zitat:

---

Deinen Verweis auf einen vorherigen Beitrag von dir habe ich gesehen und es steht auch alles so im Makro, aber trotzdem haut er mir manchmal die Ø Zeichen weg, aber halt nicht bei allen Zeichnungen.

---

Ab diesem Zeitpunkt kann ich dir da auch nicht mehr helfen. Da musst du bei den betroffenen Zeichnungen selbst debuggen (Makro im Einzelschritt laufen lassen, mit Haltepunkten arbeiten etc.), um die Ursache rauszufinden. Ich würde mich aber freuen, wenn du dann irgendwann die Ursache+Lösung hier kundtust. 

Gruß, Jens

------------------
CSWE =)

[Diese Nachricht wurde von CAD-Maler am 19. Jun. 2019 editiert.]

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

---

obereToleranz.png

Das mit den Toleranzen funktioniert nun alles super   

Die Ø Zeichen bleiben jetzt auch wieder da. Ich hatte vor deiner Lösung vor 2 Tagen bei der Bemaßung das + Präfix weggenommen, da er dann nicht mehr die Zahlen doppelt vergeben hat und dies hatte ich bis eben nicht geändert.

'Bemaßung nummerieren
                dimstring = "[" + CStr(nr) + "] " + Präfix
                DisplayDimension.SetText swDimensionTextPrefix, dimstring

                nr = nr + 1

Jetzt haut er mir dafür bei manchen Ø Zeichen jedes mal ein weiteres Ø dazu. Hatte gerade 3 Stück dort stehen.
Kann man sicher mit einer Abfrage auch korrigieren  

Und mir ist noch eine Kleinigkeit aufgefallen, welche gar nicht wirklich dramatisch ist, aber vllt bekommt man diese auch noch weg. Wenn die obere Toleranz 0 ist dann Zeigt er nach dem Maß die 0 an ohne Vorzeichen.
Beispiel ist im Anhang

Liebe Grüße
Micha

[Diese Nachricht wurde von th3kingz am 19. Jun. 2019 editiert.]

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

---

Jens mein Retter, bist du noch einmal so lieb und hilfst mir bei den Problemchen?

Liebe Grüße
Micha

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

---

Zitat:

---

Original erstellt von th3kingz:
Jens mein Retter, bist du noch einmal so lieb und hilfst mir bei den Problemchen?

Liebe Grüße
Micha

---

Oller Schleimer!   Hatte den Thread ganz aus den Augen verloren...

Zitat:

---

Wenn die obere Toleranz 0 ist dann Zeigt er nach dem Maß die 0 an ohne Vorzeichen.

---

Wie du schon festgestellt hast, lässt sich das durch ein paar Abfragen leicht lösen:

Code:

---

                    'Vorzeichen auslesen
                    V_obere = IIf(tol(1) <= 0, "", "+")
                    V_untere = IIf(tol(0) <= 0, "", "+")
                   
                    If BemTyp = 1 Then
                        Tol_obere = IIf(tol(1) = 0, "", V_obere & tol(1) & "° ")
                        Tol_untere = IIf(tol(0) = 0, "", V_untere & tol(0) & "°")
                       
                        myTable.Text(Z, 2) = Präfix & wert & "° " & Tol_obere & Tol_untere
                    Else
                        Tol_obere = IIf(tol(1) = 0, "", V_obere & tol(1) * 1000 & " ")
                        Tol_untere = IIf(tol(0) = 0, "", V_untere & tol(0) * 1000)
                       
                        myTable.Text(Z, 2) = Präfix & wert * 1000 & " " & Tol_obere &  Tol_untere
                    End If

---

Das ist jetzt "mein" Code, den wirst du vermutlich an deinen anpassen müssen. Für das Problem mit den Durchmesserzeichen komme ich ihne deinen Makro-Code nicht weiter. Bei mir funktioniert alles...  

Gruß, Jens

------------------
CSWE =)

[Diese Nachricht wurde von CAD-Maler am 01. Jul. 2019 editiert.]

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

---

Hallo Jens  

Hier mal mein Code. Das mit dem auslesen des Namens habe ich jetzt gelassen, da ich es nicht hinbekommen habe.
Finde ich jetzt aber auch nicht mehr so wichtig. Wenn die Ø Zeichen nicht mehr doppelt sind bin ich zufrieden. ( Also diese werden nur teilweise doppelt wenn ich das Makro doppelt über die Zeichnung laufen lasse)

Dim swApp As Object
Dim Part As Object
Dim Gtol As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Dim view As Object
Dim DisplayDimension As Object
Dim Dimension As Object
Dim Wert As Double
Dim tol As Variant
Dim dimstring As String
Dim myTable As Object
Dim myTextFormat As Object
Dim Präfix As String
Dim swCustPropMgr As CustomPropertyManager
Dim val As String
Dim ID As String

Sub main()

    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
 
    Set view = Part.GetFirstView
    nr = 1
 
    '########################################################################################################################
    '-> Exceldatei öffnen
    Dim oExcel As Object
   
    On Error Resume Next
 
    Set oExcel = GetObject(, "Excel.Application") '-> Versuch einen Verweis auf Excel zu bekommen
 
    If Err.Number <> 0 Then '-> Wenn ein Fehler auftritt dann läuft Excel noch nicht
        Set oExcel = CreateObject("excel.application") '-> Wenn Excel noch nicht läuft, dann wird es gestartet
        Err.Clear '-> Error zurücksetzen
    End If
    oExcel.Visible = True
 
    Dim sDateiPfad As String: sDateiPfad = "S:\Makros\\Test.xltm" '-> Dateipfad
    oExcel.workbooks.open (sDateiPfad) '-> Datei öffnen

    '########################################################################################################################
 
    '-> Verarbeitung
    Do While Not view Is Nothing
Set DisplayDimension = view.GetFirstDisplayDimension

        For j = 0 To view.GetDimensionCount - 1
            Set Dimension = DisplayDimension.GetDimension
            If DisplayDimension.Inspection = 1 Then
                Wert = Dimension.SystemValue
             
                BemTyp = Dimension.GetType
             
                If BemTyp = 1 Then  'Winkel
                    Typ = "Winkel"
                    Wert = 360 / (2 * pi) * Wert
                    Wert = Round(Wert, 3)
                Else
                    Typ = ""    ' Länge entfernt
                    Wert = Round(Wert, 6)  'Rundung, da bei Maß in Baugruppen zwischen 2 Bauteilen Gleitkommafehler an 12. Nachkommastelle auftritt
                End If
             
                tol = Dimension.GetToleranceValues
                If BemTyp = 1 Then  'Winkel
                  tol(0) = 360 / (2 * pi) * tol(0)
                  tol(0) = Round(tol(0), 3)
                  tol(1) = 360 / (2 * pi) * tol(1)
                  tol(1) = Round(tol(1), 3)
                End If
               
                Set btol = Dimension.Tolerance
                Präfix = DisplayDimension.GetText(swDimensionTextPrefix)
                If Präfix = "<MOD-DIAM>" Then Typ = "Ø"
                Präfix = Replace(Präfix, "<MOD-DIAM>", "Ø")
                If InStr(Präfix, "]") > 0 Then Präfix = Right(Präfix, Len(Präfix) - InStrRev(Präfix, "]") - 1)
             
                If Dimension.GetToleranceType = swTolSYMMETRIC Then tol(0) = -tol(1)
                If Dimension.GetToleranceType = swTolFIT Then
                    BohrPass = btol.GetHoleFitValue
                    WellPass = btol.GetShaftFitValue
                End If
             
                ' Zellen mit Werten belegen, Umwandlung in mm
                oExcel.Worksheets(1).Cells(nr + 1, 1) = nr                   'Nummer
             
                If Dimension.GetToleranceType = swTolFIT Then  'Wenn Passung
                    oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert * 1000 & " " & BohrPass & WellPass
                ElseIf Dimension.GetToleranceType = swTolSYMMETRIC Then 'Wenn symm.
                    If BemTyp = 1 Then 'Winkel
                        oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert & "° ±" & tol(1) & "°"
                    Else
                        oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert * 1000 & " ±" & tol(1) * 1000
                    End If
                Else
                    If BemTyp = 1 Then  'Winkel
                        oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert & "° +" & tol(1) & "° " & IIf(tol(0) <> 0, tol(0) & "°", "")
                    Else
                        oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert * 1000 & " +" & tol(1) * 1000 & " " & IIf(tol(0) <> 0, tol(0) * 1000, "")
                    End If
                End If
             
                If BemTyp = 1 Then  'Winkel
                    oExcel.Worksheets(1).Cells(nr + 1, 3) = Präfix & (Wert + tol(1)) & "°"      'oberes Grenzmaß
                    oExcel.Worksheets(1).Cells(nr + 1, 4) = Präfix & (Wert + tol(0)) & "°"      'unteres Grenzmaß
                Else
                   
                    oExcel.Worksheets(1).Cells(nr + 1, 3) = Präfix & (Wert + tol(1)) * 1000      'oberes Grenzmaß
                    oExcel.Worksheets(1).Cells(nr + 1, 4) = Präfix & (Wert + tol(0)) * 1000      'unteres Grenzmaß
                End If
           
            'Vorzeichen auslesen
                   'Vorzeichen auslesen
                    V_obere = IIf(tol(1) <= 0, "", "+")
                    V_untere = IIf(tol(0) <= 0, "", "+")
                   
                    If BemTyp = 1 Then
                        Tol_obere = IIf(tol(1) = 0, "", V_obere & tol(1) & "° ")
                        Tol_untere = IIf(tol(0) = 0, "", V_untere & tol(0) & "°")
                       
                        oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert & "° " & Tol_obere & Tol_untere
                    Else
                        Tol_obere = IIf(tol(1) = 0, "", V_obere & tol(1) * 1000 & " ")
                        Tol_untere = IIf(tol(0) = 0, "", V_untere & tol(0) * 1000)
                       
                        oExcel.Worksheets(1).Cells(nr + 1, 2) = Präfix & Wert * 1000 & " " & Tol_obere & Tol_untere
                    End If
           
                'Bemaßung nummerieren
                dimstring = "[" + CStr(nr) + "] " + Präfix
                DisplayDimension.SetText swDimensionTextPrefix, dimstring

                nr = nr + 1
             
            End If

            Set DisplayDimension = DisplayDimension.GetNext
        Next

Set view = view.GetNextView
    Loop
 
    boolstatus = Part.ForceRebuild3(True)
   
    'Modell holen und Eigenschaft auslesen
    Set view = Part.GetFirstView
    Set view = view.GetNextView
   
    ViewName = view.Name
    RefModelName = view.GetReferencedModelName
   
    Select Case UCase(Right(RefModelName, 6))
    Case "SLDPRT"
        SWXTypeOfFile = swDocPART
    Case "SLDASM"
        SWXTypeOfFile = swDocASSEMBLY
    Case "SLDDRW"
        SWXTypeOfFile = swDocDRAWING
    Case Else
        SWXTypeOfFile = swDocNONE
    End Select
   
    If SWXTypeOfFile = swDocNONE Then
        MsgBox "Leere Zeichnung!", vbCritical, "Fehler!"
        End
    End If
   
    ConfigName = view.ReferencedConfiguration
   
    Set model = swApp.OpenDoc(RefModelName, SWXTypeOfFile)
    Set model = swApp.ActivateDoc2(RefModelName, True, nErrors)
    Set swCustPropMgr = model.Extension.CustomPropertyManager(Empty)
   
    retval = swCustPropMgr.Get4("ID", False, val, ID)
   
    oExcel.Worksheets(1).Cells(nr + 1, 8) = RefModelName

End Sub

Liebe Grüße
Micha

[Diese Nachricht wurde von th3kingz am 02. Jul. 2019 editiert.]

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

---

Zitat:

---

Original erstellt von th3kingz:
Hallo Jens   

Hier mal mein Code.

---

Hab deinen Code mal getestet, läuft wie eine eins. :) Nach einigen rumprobieren habe ich auch den Durchmesser-fehler reproduziert bekommen und nach noch längerer Sucherei auch die Ursache dafür gefunden.

Das beste, was mir dazu einfällt, kommt von meinem Lieblings-Spitzohr:

Zitat:

---

Faszinierend, Captain!

---

Hauptursache ist diese Zeile:

Code:

---

Präfix = Replace(Präfix, "<MOD-DIAM>", "Ø")

---

An Stellen, wo man es nicht braucht, ist SWX scheinbar manchmal gar nicht so dumm...    Du schreibst ja ganz unten mit DisplayDimension.SetText die Bemaßung inkl. Nummerierung (z.B. "[1] Ø15") wieder in SWX zurück. So weit, so gut. Nach dem ForcedRebuild erkennt SWX nun, dass das zwar eine "echte" Durchmesserbemaßung (keine von Hand gepfuschte) ist, der aber vorn dran das Durchmesserzeichen fehlt. Und da wird SWX zum Highlander, es kann nämlich nur einen(s) geben, in dem Fall <MOD-DIAM>. Alles andere ist für SWX nur dummer Text, auch wenn er so ähnlich wie ein Durchmesserzeichen aussieht. (Mußt dir den Präfix mal anschauen, das sind unterschiedliche Schriftarten.)

Also nimmt SWX seine Macht in Gebrauch und klatscht fröhlich ein <MOD-DIAM> vor das Maß und freut sich, dass es die Welt gerettet hat. Und bei der nächsten Runde das gleiche Spiel: Dein Code ersetzt das einzig wahre Durchmesserzeichen (das 2. diesmal) und SWX pappt sein eigenes wieder hin. Und so weiter und so fort.

Lange Rede, gar kein Sinn: Mit

Code:

---

dimstring = "[" + CStr(nr) + "] " + Replace(Präfix, "Ø", "<MOD-DIAM>")

---

schreibst du das SolidWorks-Sehnsuchtszeichen wieder in die Bemaßung und SWX hat nichts mehr zu meckern. Da das auf der Zeichnung automatisch als Ø angezeigt wird und dein Code es beim nächsten Mal sowieso wieder erstzt, sind alle glücklich.

Und ich kann beruhigt in den Urlaub gehen... 

Gruß, Jens

------------------
CSWE =)

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

---

Ich danke dir und wünsche dir einen schönen erholsamen Urlaub 

Liebe Grüße
Micha

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