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