---

Pruefmasstabelle.png Passungen.png

Hallo Zusammen,

ich hoffe ihr könnt mir auch diesmal wieder weiterhelfen  

Folgende Aufgabe:

1. Das Makro soll die Prüfmaße in eine Tabelle schreiben mit oberes und unteres Abmaß und Durchnummerierung --> Bild im Anhang --> funktioniert naja auch soweit!
2. Das Makro soll alle Prüfmaße aus allen Zeichenblättern in "nur" eine Tabelle schreiben --> derzeitig bekomme ich es nur Blattweiße hin
3. Am Ende diese eine Tabelle (.sldtbt) als Exceltabelle (.xlsx) exportieren an einen bestimmten Ort
4. Problem mit Passungen z.B. H7 (Rundungsfehler?)und Tiefenangabe mit Auslesen --> SIEHE BILD, Tiefe 4,50mm
5. Gewinde als Prüfmaß (ich habe sehr oft Gewinde aus dem Bereich Optik (z.B.: M85x0.75) diese sollen auch aufgenommen werden in die Tabelle.
   Wenn Gewinde als Prüfmaß deklariere dann nimmt er nur das "Kernloch" aber nicht die genaue Bezeichnung und Steigung und Gewindelänge

Das Makro habe ich dank cad.de   schon soweit wie ich kam zusammengebastelt aber ohne eure Hilfe bekomme ich es nicht zu Ende gebastelt:

Hier das Makro:
---------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Dim swApp As Object
Dim Part As Object
Dim ModelDocExt As Object
Dim SymArr(2) As String
Dim tol(1) As Double

Const pi As Double = 3.14159265358979

Sub main()

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set ModelDocExt = Part.Extension

'* Prüfung ob ein Dokument aktiv ist
If Part Is Nothing Then
    MsgBox "Keine Zeichnung geladen!", vbMsgBoxSetForeground + vbInformation, "Fehler"
    Exit Sub
End If

'* Prüfung ob das aktuell aktive Dokument eine Zeichnung ist
If Part.GetType <> swDocDRAWING Then
    MsgBox "Aktive Datei ist keine Zeichnung!", vbMsgBoxSetForeground + vbInformation, "Fehler"
    Exit Sub
End If

'Papierformat auslesen
Set swSheet = Part.GetCurrentSheet
vSheetProps = swSheet.GetProperties
Size = vSheetProps(0)

'Schrifthöhe für allg. Tabellen auf 2.5 setzen
Set myTextFormat = Part.Extension.GetUserPreferenceTextFormat(swUserPreferenceTextFormat_e.swDetailingGeneralTableTextFormat, swUserPreferenceOption_e.swDetailingGeneralTable)
myTextFormat.CharHeight = 0.0025
boolstatus = Part.Extension.SetUserPreferenceTextFormat(swUserPreferenceTextFormat_e.swDetailingGeneralTableTextFormat, swUserPreferenceOption_e.swDetailingGeneralTable, myTextFormat)

Vorlage = "C:\abc\def\geh\Vorlage_Pruefmasstabelle.sldtbt"    '<---- Pfad eintragen

'Nullpunkt der Tabelle festlegen
Select Case Size
    Case 7              'A4
        X = 0.20492
        Y = 0.28685
    Case 8              'A3
        X = 0.41033
        Y = 0.28676
    Case 9              'A2
        X = 0.57778
        Y = 0.40968
    Case 10             'A1
        X = 0.82889
        Y = 0.58466
    Case 11             'A0
        X = 1.17794
        Y = 0.83028
End Select
       
        X1 = X - 0.075  'X1 für Text-Pos.
       
Set myTable = Part.InsertTableAnnotation2(False, X, Y, 2, Vorlage, 6, 7)  '(Am Verankergspkt einfügen, X, Y, Verankergspkt re oben, Vorlage, Zeilen, Spalten)
myTable.Anchored = False

Set view = Part.GetFirstView
nr = 1

Do While Not view Is Nothing
   
    '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
                Typ = "Winkel"
                Wert = 360 / (2 * pi) * Wert
                If DisplayDimension.GetPrimaryPrecision2 < 0 Then
                    BemPrecision = ModelDocExt.GetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swDetailingAngularDimPrecision, swUserPreferenceOption_e.swDetailingAngleDimension)
                Else
                    BemPrecision = DisplayDimension.GetPrimaryPrecision2
                End If
              
                Wert = Round(Wert, BemPrecision)
            Else
                Typ = "Länge"
            End If
          
            'tol = Dimension.GetToleranceValues
            lWarning = Dimension.Tolerance.GetMinValue2(tol(0))
            lWarning = Dimension.Tolerance.GetMaxValue2(tol(1))
           
            If BemTyp = 1 Then
             
               If DisplayDimension.GetPrimaryTolPrecision2 = -2 Then
                    TolPrecision = ModelDocExt.GetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swDetailingAngularTolPrecision, swUserPreferenceOption_e.swDetailingAngleDimension)
               ElseIf DisplayDimension.GetPrimaryTolPrecision2 = -3 Then
                    TolPrecision = BemPrecision
               Else
                    TolPrecision = DisplayDimension.GetPrimaryTolPrecision2
               End If
             
               tol(0) = 360 / (2 * pi) * tol(0)
               tol(0) = Round(tol(0), TolPrecision)
             
               tol(1) = 360 / (2 * pi) * tol(1)
               tol(1) = Round(tol(1), TolPrecision)

            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 & " " & BohrPass & WellPass
            ElseIf Dimension.GetToleranceType = swTolSYMMETRIC Then 'Wenn symm.
                If BemTyp = 1 Then
                    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
                    If tol(1) > 0 And tol(0) > 0 Then
                        myTable.Text(Z, 2) = Präfix & Wert & "° +" & tol(0) & "° +" & tol(1) & "°"
                    ElseIf tol(1) < 0 And tol(0) < 0 Then
                        myTable.Text(Z, 2) = Präfix & Wert & "° " & tol(1) & "° " & tol(0) & "°"
                    Else
                        myTable.Text(Z, 2) = Präfix & Wert & "° +" & tol(1) & "° " & tol(0) & "°"
                    End If
                Else
                    If tol(1) > 0 And tol(0) > 0 Then
                        myTable.Text(Z, 2) = Präfix & Wert * 1000 & " +" & tol(0) * 1000 & " +" & tol(1) * 1000
                    ElseIf tol(1) < 0 And tol(0) < 0 Then
                        myTable.Text(Z, 2) = Präfix & Wert * 1000 & " " & tol(1) * 1000 & " " & tol(0) * 1000
                    Else
                        myTable.Text(Z, 2) = Präfix & Wert * 1000 & " +" & tol(1) * 1000 & " " & tol(0) * 1000
                    End If
                End If
            End If
           
            If BemTyp = 1 Then
                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
        Set DisplayDimension = DisplayDimension.GetNext
    Next
   
    Z = nr + 1
   
    'Form- und Lagetoleranzen
       
    Count = view.GetGTolCount
   
    If Count > 0 Then
        Annotations = view.GetGTols
       
        For j = 0 To UBound(Annotations)
            Set gtol = Annotations(j)
           
            'Toleranz 1
           
            Tolwert1 = gtol.GetFrameValues(1)
                Tol1 = Tolwert1(0)
                tol2 = Tolwert1(1)
                Bezug = Tolwert1(2)
           
            If nr > 1 Then
                boolstatus = myTable.InsertRow(swTableItemInsertPosition_After, Z - 1)
                boolstatus = myTable.UnmergeCells(Z, 0)
            End If
               
            c = 1
            For idx = 0 To gtol.GetTextCount - 1
                If Left(gtol.GetTextAtIndex(idx), 1) = "<" Then
                    SymArr(c) = gtol.GetTextAtIndex(idx)
                    c = c + 1
                End If
            Next idx
   
           
            myTable.Text(Z, 0) = "#" & nr                    'Nummer
           
            myTable.Text(Z, 1) = SymArr(1)
           
            If tol2 <> "" Then
                myTable.Text(Z, 2) = Tol1 & " / " & tol2
            Else
                myTable.Text(Z, 2) = Tol1
            End If
           
            myTable.Text(Z, 3) = "------"
            myTable.Text(Z, 4) = "------"
           
            Tol1Nr = CStr(nr)
           
            nr = nr + 1
            Z = nr + 1
           
            'Toleranz2
           
            Tolwert2 = gtol.GetFrameValues(2)
            If Tolwert2(0) <> "" Then
                Tol1 = Tolwert2(0)
                tol2 = Tolwert2(1)
                Bezug = Tolwert2(2)
           
                boolstatus = myTable.InsertRow(swTableItemInsertPosition_After, Z - 1)
                boolstatus = myTable.UnmergeCells(Z, 0)
               
                myTable.Text(Z, 0) = "#" & nr                   'Nummer
               
                myTable.Text(Z, 1) = SymArr(2)

                If tol2 <> "" Then
                    myTable.Text(Z, 2) = Tol1 & " / " & tol2
                Else
                    myTable.Text(Z, 2) = Tol1
                End If
               
                myTable.Text(Z, 3) = "------"
                myTable.Text(Z, 4) = "------"
           
                Tol2Nr = CStr(nr)

                nr = nr + 1
            End If
            If Tolwert2(0) <> "" Then
                tolstring = "#" & Tol1Nr & ", #" & Tol2Nr
            Else
                tolstring = "#" & Tol1Nr
            End If
           
            boolstatus = gtol.SetText(swGTolTextCalloutBelow, tolstring)
            Tol1Nr = ""
            Tol2Nr = ""
        Next j
    End If
   
    Set view = view.GetNextView
   
Loop

'Text einfügen

Set myNote = Part.InsertNote("Prüfung erforderlich!")

myNote.LockPosition = False
myNote.Angle = 0
boolstatus = myNote.SetBalloon(0, 0)

Set myAnnotation = myNote.GetAnnotation()

If Not myAnnotation Is Nothing Then
    For f = 0 To myAnnotation.GetTextFormatCount - 1
        Set myTextFormat = myAnnotation.GetTextFormat(f)
        myTextFormat.CharHeight = 0.005
    Next f
   
    longstatus = myAnnotation.SetLeader3(swLeaderStyle_e.swNO_LEADER, 0, True, False, False, False)
    boolstatus = myAnnotation.SetPosition(X1, 0.11, 0)
    boolstatus = myAnnotation.SetTextFormat(0, False, myTextFormat)
End If

Part.ClearSelection2 True
Part.WindowRedraw
boolstatus = Part.ForceRebuild3(True)

End Sub

----------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Ich danke jeden Unterstützer für seine Mithilfe  

Gruß René

[Diese Nachricht wurde von Rene82 am 27. Mai. 2021 editiert.]

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

---

Zitat:

---

Original erstellt von Rene82:
Folgende Aufgabe:

1. Das Makro soll die Prüfmaße in eine Tabelle schreiben mit oberes und unteres Abmaß und Durchnummerierung --> Bild im Anhang --> funktioniert naja auch soweit!
2. Das Makro soll alle Prüfmaße aus allen Zeichenblättern in "nur" eine Tabelle schreiben --> derzeitig bekomme ich es nur Blattweiße hin
3. Am Ende diese eine Tabelle (.sldtbt) als Exceltabelle (.xlsx) exportieren an einen bestimmten Ort
4. Problem mit Passungen z.B. H7 (Rundungsfehler?)und Tiefenangabe mit Auslesen --> SIEHE BILD, Tiefe 4,50mm
5. Gewinde als Prüfmaß (ich habe sehr oft Gewinde aus dem Bereich Optik (z.B.: M85x0.75) diese sollen auch aufgenommen werden in die Tabelle.
   Wenn Gewinde als Prüfmaß deklariere dann nimmt er nur das "Kernloch" aber nicht die genaue Bezeichnung und Steigung und Gewindelänge

Das Makro habe ich dank cad.de    schon soweit wie ich kam zusammengebastelt aber ohne eure Hilfe bekomme ich es nicht zu Ende gebastelt:

Hier das Makro:

---

Kommt mir irgendwie bekannt vor, das Makro... 

Folgendes würde ich probieren (alles ungetestet):

2. Es sollte eigentlich genügen, alles zwischen

Code:

---

Set view = Part.GetFirstView
nr = 1

---

und

Code:

---

  Loop

---

in eine For Each Sheet-Schleife zu packen. Also jedes Blatt nacheinander aktivieren und die beiden Auslese-Schleifen durchlaufen lassen. Der Pointer zeigt ja weiterhin zur Tabelle auf Blatt 1.

3. Du hast am Ende des Loops immer noch den pointer zur Tabelle. Die kannst du mit SaveAsText2 als Text/csv-Datei rausspeichern.
Alternativ ein Excel öffnen und die Tabelle Zeile für Zeile direkt rüberkopieren.
Alternativ die Tabelle selektieren und den "Speichern unter" Befehl aus dem RMT-Menü in den swcommands suchen oder per Recorder aufnehmen und damit weitermachen.

4. Ist das Teil evtl. ein Importteil? Da kommen so krumme Maße manchmal raus. Das einfachste wäre den Bemaßungswert vorm Schreiben entsprechend zu runden.
Müsste die Tiefe dann nicht ein eigenes Prüfmaß werden (=irgendwo bemaßen und als PM kennzeichnen)? Ansonsten musst du irgendwie versuchen, von dem Maß über das Feature an die Tiefe zu kommen. Stell ich mir sehr umständlich vor.

5. Keine Idee.

Gruß, jens

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

---

Hallo Jens,

da hat sich ja der richtige gleich gemeldet    !

zu 4. Nein es ist kein Importteil (step,Iges, etc.), das Teil habe ich selbst erstellt und über den Bohrungsmanager demenstprechend deklariert als Stiftlochbohrung mit H7 Passung und Tiefe. Ich bekomme es nicht hin das dann in der Prüfmaßtabelle das Maß 4 übernommen wird sondern es wird mit unzähligen Nachkommastellen komische Sachen gemacht mit allen anderen "normalen" Maßen funktioniert es ja (35,99 +0 -0,03) - nur wenn es eben eine Passung (H7 / H6 / m6 / g6 / gemacht wird eben nicht! da bekomme ich eben immer 3,9999999999998 +0,012 0 als Ergebnis!

Nr. 2 und 3 muss ich noch umsetzen, irgendwie --> Man ist halt kein Programmiere und freut sich über Cad.de 

Gruß René

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

---

Hallo René,

schönes Makro hast Du da

Wegen der Kommastellen
ich kenn das vom Passungstabellen Makro
(das ist meiner Meinung ein Bug von SWX)
Du hast 2. Optionen
1. Du rundest auf z.B.: 6 Kommastellen, dann sollte die Anzeige wieder passen
2. Du rundest auf die für die Bemalung eingestellten Kommastellen

ich hab mich damals für Option 1 entschieden, weil ich denke,
dass 6 Kommastellen, für die meisten Anwendungsfälle,  genau genug sind

Noch ein Tipp
versuch mal das Makro in mehrere Subs und Functions aufzuteilen
das ist ev. beim Erstellen geringfügig aufwändiger
aber wenn Du etwas erweiterst und/oder beim Debuggen ist das sehr hilfreich

------------------
Grüße
Heinz

[Diese Nachricht wurde von nahe am 27. Mai. 2021 editiert.]

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

---

Hallo René,

könntest bitte auch die Tabellenvorlage posten?

------------------
Grüße
Heinz

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

---

Vorlage_Pruefmasstabelle.zip

Hallo Heinz,

die Tabelle liegt im Anhang.

Ich bin kein Makro-Schreiber  , könnt ihr mir daher helfen mit den Punkten:

2. Das Makro soll alle Prüfmaße aus allen Zeichenblättern in "nur" eine Tabelle schreiben --> derzeitig bekomme ich es nur Blattweiße hin
3. Am Ende diese eine Tabelle (.sldtbt) als Exceltabelle (.xlsx) exportieren an einen bestimmten Ort.

Ich komme mit diesen Makroschreiben nicht klar!

Ich danke euch!

Gruß René

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

---

Hallo René,

ich werd mir das mal ansehen, wird aber dauern

zu 2.)
das ist ein Grund warum ich empfehle das Makro auf mehrere Funktionen aufzuteilen

z.B.:
Funktion-1  durchläuft die Blätter der Reihe nach (wie von Jens schon geschrieben)
Funktion-2  wird in der Schleife von Funktion-1 aufgerufen und liefert eine Liste pro Blatt mit den Daten
Funktion-3  hängt die Liste vom Blatt an die Gesamtliste an
            (Frage was passiert mit doppelten Einträgen?)
Funktion-4  erstellt die Tabelle auf dem ersten Blatt
Funktion-5  erledigt den Export

Du wirst im Lauf der Zeit, wahrscheinlich das Makro noch erweitern um
Sonderfälle und Fehler abfangen und zu behandeln und die Funktionalität erweitern
Es wird dann sehr schnell sehr unübersichtlich, wenn Du alles in eine Funktion packst

zu 3.)
das ist zwar nicht kompliziert aber etwas Tipperei
zum Anfang kannst Du Dir das mal ansehen
https://ww3.cad.de/foren/ubb/Forum2/HTML/031309.shtml

noch eine Empfehlung
ich würde einen Typ, pro Tabellenzeile, definieren z.B.:

Type zeile
  Id        As String
  Art      As String
  Mass      As String
  Max_Mass  As String
  Min_Mass  As String
  Blatt    As String
End Type

und dann eine Liste mit den Zeilen
Dim DatList() As zeile

Zu Deiner Anmerkung
"Ich komme mit diesen Makroschreiben nicht klar!"

- Ich kann nur, immer wieder, eine Schulung bei Deinem Re-Seller empfehlen
- auf jeden Fall die Online-Hilfe durchstöbern
  dort sind jede Menge Beispiele
- Nicht gleich "die Flinte ins Korn werfen"
- eine Buchempfehlung von mir
https://www.amazon.de/Weniger-schlecht-programmieren-Kathrin-Passig/dp/3897215675/ref=sr_1_1?dchild=1&hvadid=80195661727231&hvbmt=be&hvdev=c&hvqmt=e&keywords=weniger+schlecht+programmieren&qid=1622190074&sr=8-1
 
Achtung:
hat nichts mit VBA und/oder SWX Programmierung zu tun

------------------
Grüße
Heinz

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

---

Hallo Zusammen,

erstmal vielen lieben Dank für eure Unterstützung, ohne diese würde ich gnadenlos scheitern.

Das mit dem Runden der Werte habe ich hinbekommen, mein größtes Problem ist es den Makro-Text richtig zu lesen und auch mit der API-Hilfe fällt es mir sehr schwer dies umzusetzen. Wenn ich in der API-Hilfe suche nach "GetNextSheet" oder "Loop", "For Each Sheet" verstehe ich leider nicht wie ich es sinnvoll und angepasst einsetzen muss bzw. übernehmen muss.

Ich benötige daher weiterhin die Hilfe der Leute die "programmieren" können, ich kann nur über Probieren machen und dies endet derzeitig immer irgendwie in eine Sackgasse des nicht funktionierens.

Gruß René

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

---

Hallo René,

schau Dir mal in der Online Hilfe das Beispiel
"Get Loaded Sheets Example (VB.NET)"
an

------------------
Grüße
Heinz

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