Hallo
Ich habe viele Hacks ausprobiert, um dorthin zu gelangen, aber nichts hat funktioniert
Ich möchte die wackeligen Bemaßungen auf einer Zeichnung automatisch über ein Makro entfernen. Also habe ich dafür die Makroaufnahme verwendet, aber letztere funktioniert nach der Aufnahme nicht, wenn ich sie erneut abspiele. Sie startet selbst, ändert aber nichts...
Haben Sie eine Lösung?
Ps: Ich möchte es unbedingt in VBA über Excel verwalten und bin ein Anfänger.
Vielen Dank
Die Rippen eines Stückes oder die einer Zeichnung?
Für ein Zimmer:
Option Explicit
Dim swModel As SldWorks.ModelDoc2
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swFeat As SldWorks.Feature
Dim swSubFeat As SldWorks.Feature
Dim swDispDim As SldWorks.DisplayDimension
Dim swAnn As SldWorks.Annotation
Dim boolstatus As Boolean
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swFeat = swModel.FirstFeature
Do While Not swFeat Is Nothing
'Debug.Print " " + swFeat.Name
Set swSubFeat = swFeat.GetFirstSubFeature
Do While Not swSubFeat Is Nothing
' Debug.Print " " + swSubFeat.Name
DeleteFeatureDim swSubFeat
Set swSubFeat = swSubFeat.GetNextSubFeature
Loop
DeleteFeatureDim swFeat
Set swFeat = swFeat.GetNextFeature
Loop
End Sub
Sub DeleteFeatureDim(ByVal swFeat As SldWorks.Feature)
Dim swDispDim As SldWorks.DisplayDimension
Dim swAnn As SldWorks.Annotation
Dim boolstatus As Boolean
Set swDispDim = swFeat.GetFirstDisplayDimension
Do While Not swDispDim Is Nothing
Set swAnn = swDispDim.GetAnnotation
'Debug.Print " [" & swDim.FullName & "] = " & swDim.GetSystemValue2("")
If swAnn.IsDangling Then
boolstatus = swFeat.Select2(False, 0)
swModel.EditSketch
boolstatus = swAnn.Select3(False, Nothing)
boolstatus = swModel.Extension.DeleteSelection2(0)
swModel.InsertSketch2 True
End If
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
Loop
End Sub
Für eine Zeichnung:
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swDraw As DrawingDoc
Dim swSheet As Sheet
Dim swView As View
Dim boolstatus As Boolean
Dim swAnn As Annotation
Dim swDispDim As DisplayDimension
Dim vSheetNames As Variant
Dim i As Integer
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel.GetType <> SwConst.swDocumentTypes_e.swDocDRAWING Then Exit Sub
Set swDraw = swModel
swModel.ClearSelection2 (True)
vSheetNames = swDraw.GetSheetNames
For i = 0 To UBound(vSheetNames)
swDraw.ActivateSheet vSheetNames(i)
Set swSheet = swDraw.Sheet(vSheetNames(i))
Set swView = swDraw.GetFirstView
Do While Not swView Is Nothing
Set swAnn = swView.GetFirstAnnotation3
Do While Not swAnn Is Nothing
If swAnn.IsDangling Then
boolstatus = swAnn.Select3(True, Nothing)
End If
Set swAnn = swAnn.GetNext3
Loop
Set swView = swView.GetNextView
Loop
boolstatus = swModel.DeleteSelection(True)
swModel.ClearSelection2 (True)
Next
swModel.ClearSelection2 (True)
End Sub
Vielen Dank für Ihre Lösung, aber leider kann ich sie nicht zum Laufen bringen. Das Problem liegt wahrscheinlich nicht an Ihrer Lösung, sondern eher an meinen Fähigkeiten.
Ich verwalte mein gesamtes Projekt per Excel-Makro mit aktivierten SolidWorks Referenzwerkzeugen. Ich integriere auch all das "Dim" und andere Dinge in die Methode, weil ich noch nicht alle Feinheiten beherrsche. Und ich schaue mir Ihre Methode an, kann aber nicht verstehen, welche Parameter geändert werden müssen .
Welches Makro verwenden Sie? Stück oder Zeichnung?
Makros funktionieren als SolidWorks Makro (gespeichert in einer SWP-Datei). Können Sie zunächst einmal versuchen, zu sehen, ob es so funktioniert?
Danach kann das Problem nur von der Art und Weise herrühren, wie es in die Excel-Datei eingebettet ist . Können Sie die Datei anhängen?
Ich verwende die Makrozeichnungen
Ich habe versucht, mein Problem zu umgehen, indem ich die importierten Abmessungen von 3D nach 2D markiert habe, aber ich bin auch ein Leerer...
Leider handelt es sich dabei um eine sensible Datei für das Unternehmen, so dass ich Ihnen nur ein paar Schnipsel weitergeben kann. So war ich gezwungen, einen Großteil der Daten zu löschen, objektorientiertes Programmieren praktiziere ich noch nicht, aber das wird mein nächster Schritt sein.
Ich habe gerade getestet, indem ich dummerweise Ihr Makro in eine neue Solidworks-Makrodatei kopiert habe, es läuft, aber es gibt keine Ergebnisse. Ich habe die für die Zeichnungen genommen. Ich verstehe wirklich nicht, was ich falsch mache...
Wenn du dein Stück nicht zusammenfügen kannst, kannst du einen Würfel mit einer Zeichnung und einer wackeligen Bemaßung erstellen, wie es bei deinem Stück gemacht wird. Überprüfen Sie, ob das Makro in dieser Zeichnung nicht funktioniert, und fügen Sie dann sldprt, slddrw und swp an.
Andernfalls können Sie dies versuchen (angepasst an https://www.eng-tips.com/faqs.cfm?fid=153 )
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.DrawingDoc
Dim dwgView As SldWorks.View
Dim dispDimension As SldWorks.DisplayDimension
Dim dwgDimension As SldWorks.Dimension
Dim dwgNote As SldWorks.Note
Dim dwgWeld As SldWorks.WeldSymbol
Dim dwgAnnotation As SldWorks.Annotation
Dim attachedEntitiesArray As Variant
Dim attachedEntityTypes As Variant
Dim bRemoveLastFlag As Boolean
Dim s1 As String
Dim sViewName As String, sDwgName As String
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set dwgView = Part.GetFirstView
Do While Not dwgView Is Nothing
'Travserse Through the Dimensions
Set dwgView = dwgView.GetNextView
If Not dwgView Is Nothing Then
sViewName = dwgView.Name
'Travserse through all of the dimensions in this view
Set dispDimension = dwgView.GetFirstDisplayDimension3
Do While Not dispDimension Is Nothing
Set dwgDimension = dispDimension.GetDimension
bRemoveLastFlag = False
If dwgDimension.Value = 0 Then
'Delete the Dimension
If InStr(1, dwgDimension.FullName, "Annotations") Then
'The next dimension must be selected before this one can be removed
bRemoveLastFlag = True
s1 = dwgDimension.Name & "@" & sViewName
End If
End If
Set dispDimension = dispDimension.GetNext3
If bRemoveLastFlag = True Then
Part.SelectByID s1, "DIMENSION", 0, 0, 0
Part.DeleteSelection False
bRemoveLastFlag = False
End If
Loop
'Travserse through all of the reference dimensions in this view
Set dispDimension = dwgView.GetFirstDisplayDimension3
Do While Not dispDimension Is Nothing
Set dwgAnnotation = dispDimension.GetAnnotation
'Only allow this to act on Reference Dimensions
If dwgAnnotation.GetName Like "RD*" Then
attachedEntitiesArray = dwgAnnotation.GetAttachedEntities
attachedEntityTypes = dwgAnnotation.GetAttachedEntityTypes
If IsEmpty(attachedEntitiesArray) Or IsNull(attachedEntitiesArray) Then
'Delete the Ref Dim
bRemoveLastFlag = True
s1 = dwgAnnotation.GetName & "@" & dwgView.Name
ElseIf attachedEntityTypes(0) = 0 Or attachedEntitiesArray(0) Is Nothing Then
'Delete the Ref Dim
bRemoveLastFlag = True
s1 = dwgAnnotation.GetName & "@" & dwgView.Name
ElseIf (UBound(attachedEntitiesArray) + 1) >= 2 Then
If attachedEntityTypes(1) = 0 Or attachedEntitiesArray(1) Is Nothing Then
'Delete the Ref Dim
bRemoveLastFlag = True
s1 = dwgAnnotation.GetName & "@" & dwgView.Name
End If
Else
'Attached
End If
End If
Set dispDimension = dispDimension.GetNext3
If bRemoveLastFlag = True Then
Part.SelectByID s1, "DIMENSION", 0, 0, 0
Part.DeleteSelection False
bRemoveLastFlag = False
End If
Loop
End If
Loop
MsgBox "Done!"
End Sub
Ich habe gerade getestet, was du mir gegeben hast. Ich habe zwar das "Done", das am Ende angezeigt wird, aber ich habe immer noch meine wackelige Bewertung auf der Karte. Ich bin Ihrem Rat gefolgt und habe ein einfaches Stück zum Testen erstellt. Ich lege es dir bei.
Und hier ist die Situation, die ich versuche zu lösen.
Ich bewerte alle meine Piercings im Voraus, aber einige können deaktiviert werden. Dadurch sind die bereits vorhandenen Dimensionen nicht mehr brauchbar, also überflüssig und wackelig. Letzteres möchte ich mit meinem Makro eliminieren.
Ich habe es mit SW2016 versucht und das erste Makro funktioniert (allerdings nicht das letzte)
Hier ist es im swp-Format
Vielen Dank für die perfekte Arbeit und ich habe es sogar geschafft, es für Excel anzupassen.