Hallo
Ik heb veel hacks geprobeerd om er te komen, maar niets werkte
Ik wil de wiebelige afmetingen, op een tekening, automatisch verwijderen via een macro. Dus ik heb hiervoor macro-opname gebruikt, maar dat laatste na het opnemen werkt niet als ik het opnieuw afspeel. Ze lanceert zichzelf, maar verandert niets...
Heeft u een oplossing?
Ps: Ik wil het absoluut beheren in VBA via Excel en ik ben een beginner.
Bedankt
De ribben van een stuk of die van een tekening?
Voor één kamer:
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
Voor een tekening:
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
Bedankt voor je oplossing, maar helaas krijg ik het niet aan de praat . Het probleem komt waarschijnlijk niet voort uit jouw oplossing, maar meer uit mijn vaardigheden.
Ik beheer mijn hele project via een Excel-macro met de SolidWorks-referentietools ingeschakeld. Ik integreer ook alle "Dim" en andere dingen in de methode omdat ik nog niet alle subtiliteiten onder de knie heb. En ik kijk naar uw methode, maar ik kan niet begrijpen welke parameters moeten worden gewijzigd.
Welke macro gebruik je? Stuk of tekening?
Macro's werken als een SolidWorks-macro (opgeslagen in een swp-bestand). Allereerst, kun je proberen om te zien of het zo werkt?
Nadat het probleem alleen kan komen door de manier waarop het is ingebed in het Excel-bestand. Kunt u het bestand bijvoegen?
Ik gebruik de macro tekeningen
Ik heb geprobeerd mijn probleem te omzeilen door de geïmporteerde afmetingen van 3D naar 2D te markeren, maar ik ben ook een blanco...
Helaas is dit voor het bedrijf een gevoelig bestand, dus ik kan je maar een paar fragmenten doorgeven. Ik was dus genoodzaakt om een groot deel van de gegevens te verwijderen, ik doe nog niet aan objectgeoriënteerd programmeren maar dit wordt mijn volgende stap.
Ik heb net getest door dom je macro te kopiëren naar een nieuw Solidworks-macrobestand , het wordt uitgevoerd, maar er zijn geen resultaten. Ik nam die voor de tekeningen. Ik begrijp echt niet wat ik verkeerd doe...
Als je je stuk niet kunt samenvoegen, kun je een kubus maken met een tekening en een wiebelige dimensie zoals die op je stuk wordt gedaan. Controleer of de macro niet werkt op deze tekening en voeg vervolgens de sldprt, slddrw en swp toe.
Anders kun je dit proberen (aangepast van 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
Ik heb net getest wat je me gaf. Ik heb wel de "Gereed" die aan het einde wordt weergegeven, maar ik heb nog steeds mijn wiebelige beoordeling op de kaart. Ik heb je advies opgevolgd om een eenvoudig stuk te maken om te testen. Ik sluit het voor u in.
En hier is de situatie die ik probeer op te lossen.
Ik beoordeel al mijn piercings van tevoren, maar sommige kunnen invalide worden. Hierdoor zijn de afmetingen die al aanwezig zijn niet meer bruikbaar, dus zijn ze overbodig en wiebelig. Met mijn macro zou ik dat laatste willen elimineren.
Ik heb het van jouw kant geprobeerd met SW2016 en de eerste macro werkt (niet de laatste wel)
Hier is het in swp-formaat
Bedankt voor het perfecte werk en ik ben er zelfs in geslaagd om het aan te passen voor Excel.