Witam
Próbowałem wielu hacków, aby się tam dostać, ale nic nie działało
Chcę usunąć chybotliwe wymiary na rysunku automatycznie za pomocą makra. Użyłem więc do tego nagrywania makr, ale to ostatnie po nagraniu nie działa, gdy odtwarzam je ponownie. Ona sama się wystrzeliwuje, ale niczego nie zmienia...
Czy masz rozwiązanie?
Ps: Absolutnie chcę zarządzać tym w VBA za pomocą Excela i jestem nowicjuszem.
Dziękuję
Żebra w utworze czy w rysunku?
Dla jednego pokoju:
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
Dla rysunku:
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
Dziękuję za rozwiązanie, ale niestety nie mogę go zmusić do działania. Problem prawdopodobnie nie wynika z twojego rozwiązania, ale bardziej z moich umiejętności.
Zarządzam całym projektem za pomocą makra programu Excel z włączonymi narzędziami odniesienia SolidWorks. Integruję również wszystkie "Dim" i inne rzeczy z tą metodą, ponieważ nie opanowałem jeszcze wszystkich subtelności. A ja patrzę na twoją metodę, ale nie mogę zrozumieć, które parametry trzeba zmodyfikować.
Jakiego makra używasz? Utwór czy rysunek?
Makra działają jako makra SolidWorks (zapisane w pliku swp). Przede wszystkim, czy możesz spróbować sprawdzić, czy to tak działa?
Po tym, jak problem może wynikać tylko ze sposobu, w jaki jest osadzony w pliku Excel. Czy możesz załączyć plik?
Korzystam z rysunków makr
Próbowałem obejść mój problem, zaznaczając zaimportowane wymiary z 3D do 2D, ale jestem też pusty...
Niestety dla firmy jest to poufny plik, więc mogę przekazać Wam tylko kilka fragmentów. Zostałem więc zmuszony do usunięcia dużej części danych, nie praktykuję jeszcze programowania obiektowego, ale to będzie mój kolejny krok.
Właśnie przetestowałem, głupio kopiując twoje makro do nowego pliku makra Solidworks , działa, ale nie ma żadnych wyników. Wziąłem ten do rysunków. Naprawdę nie rozumiem, co robię źle...
Jeśli nie możesz połączyć swojego elementu, możesz utworzyć sześcian z rysunkiem i chybotliwym wymiarem, tak jak to jest zrobione na twoim elemencie. Sprawdź, czy makro nie działa na tym rysunku, a następnie dołącz pliki sldprt, slddrw i swp.
W przeciwnym razie możesz spróbować tego (na podstawie 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
Właśnie przetestowałem to, co mi dałeś. Mam "Gotowe", które jest wyświetlane na końcu, ale nadal mam moją chwiejną ocenę na mapie. Poszedłem za twoją radą, aby zrobić prosty kawałek do testów. Załączam go do Ciebie.
A oto sytuacja, którą staram się rozwiązać.
Wszystkie moje kolczyki oceniam wcześniej, ale niektóre mogą stać się niepełnosprawne. W rezultacie wymiary, które już są obecne, nie są już przydatne, więc są zbędne i chwiejne. Za pomocą mojego makra chciałbym wyeliminować to drugie.
Próbowałem z Twojej strony z SW2016 i pierwsze makro działa (choć nie ostatnie)
Oto jest w formacie swp
Dziękuję za jego doskonałą pracę i udało mi się nawet dostosować go do Excela.